by Dan T (1 Submission)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Thu 12th August 2004
Date Added: Mon 8th February 2021
Rating: (1 Votes)
A selection of useful maths functions
API Declarations
'if you find any of these functions useful or if you have any suggestions for more funcions, let me know
Public Const Pi = 3.141592653589
Public Const RadToDegRatio = 57.29577951
Public Const DegToRadRatio = 0.01745329252
Function FactAdd(ByVal Num As Long) As Double
'Function takes a number n and adds all numbers preceeding n to one another
'The function does it in a slightly quicker way by utilising the triangle
'number nature of the problem
FactAdd = (Num + 1) * (Num / 2)
End Function
Function Factorial(ByVal Num As Long) As Integer
Dim x As Integer
For x = 1 To Num
Factorial = Factorial * Num
Next Num
End Function
Function AreaCircle(ByVal Radius As Integer) As Integer
AreaCircle = Pi * Radius ^ 2
End Function
Function CircCircle(ByVal Radius As Integer) As Integer
CircCircle = 2 * Pi * Radius
End Function
Function ExtAngle(ByVal NumSides As Integer) As Integer
'Function returns external angle of a shape given number of sides
ExtAngle = 180 - (360 / NumSides)
End Function
Function IntAngle(ByVal NumSides As Integer) As Integer
'Function returns internal angle of a shape given number of sides
IntAngle = (360 / NumSides)
End Function
Function AreaShape(ByVal Sidelength As Integer, ByVal NumSides As Integer) As Integer
'Function Calculates area of any regular shape gven side length and number of sides
Dim HLength As Integer 'Carries Height of triangles
Dim SectionArea As Integer 'Carries areas of triangles
HLength = (Sin(DegToRad(IntAngle(NumSides))) * Sidelength) + (Sidelength / 2)
SectionArea = (HLength * (Sidelength / 2))
AreaShape = SectionArea * NumSides
End Function
Function Gradiant(ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
Gradiant = (Y2 - Y1) / (X2 - X1)
End Function
Function PointDistance(ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer)
'Function returns distance between two points
PointDistance = Sqr(((X2 - X1) ^ 2) + ((Y2 - Y1) ^ 2))
End Function
Function MidPoint(ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer, ByVal ReturnCoord As String) As Double
Dim x As Double
Dim y As Double
x = (X1 + X2) / 2 'Calculate X Midpoint
y = (Y1 + Y2) / 2 'Calculate Y Midpoint
If UCase$(ReturnCoord) = "X" Or LCase$(ReturnCoord) = "x" Then
MidPoint = x
End If
If UCase$(ReturnCoord) = "Y" Or LCase$(ReturnCoord) = "y" Then
MidPoint = y
End If
End Function
Function IsFactor(ByVal Factor As Long, ByVal Number As Long) As Boolean
If Factor Mod Number = 0 Then 'check if Number divides into Factor exactly
IsFactor = True 'if it does returns True
Else
IsFactor = False 'If it does not return false
End If
End Function
Function Quadratic(ByVal A As Integer, ByVal B As Integer, ByVal C As Integer, ByVal ReturnNum As Integer)
'Function Returns one of two possible values of X for a quadratic Equation of the
'form ax^2 + bx + c = 0
Dim X1, X2 'Dim Holding Variable
X1 = -B + (Sqr((B ^ 2) - (4 * A * C) / (2 * A))) 'Calculate first possible value
X2 = -B - (Sqr((B ^ 2) - (4 * A * C) / (2 * A))) 'Calculate second possible value
If ReturnNum = 1 Then 'Decide which value to return
Quadratic = X1 'based on ReturnNum
Else
Quadratic = X2
End If
End Function
Function RadToDeg(Radians As Integer) As Double
RadToDeg = Radians * (180 / Pi)
End Function
Function DegToRad(ByVal Degrees As Integer) As Double
DegToRad = Degrees * (Pi / 180)
End Function
Function Perpendicular(ByVal m1 As Integer, ByVal m2 As Integer) As Boolean
'Function takes two gradiants and returns true if the lines are perpendicular
If m1 * m2 = -1 Then
Perpendicular = True
Else
Perpendicular = False
End If
End Function
Function QuadraticRoots(ByVal A As Integer, ByVal B As Integer, ByVal C As Integer) As Integer
'Function returns state of roots of quadratic equations
'Returns 1 for Real Different Roots
'Returns 0 for real Same Roots
'Returns -1 for imaginary roots
If ((B ^ 2) - (4 * A * C)) > 0 Then QuadraticRoots = 1
If ((B ^ 2) - (4 * A * C)) = 0 Then QuadraticRoots = 0
If ((B ^ 2) - (4 * A * C)) < 0 Then QuadraticRoots = -1
End Function
Function ArcLength(ByVal angle As Integer, ByVal Radius As Integer) As Integer
ArcLength = (angle / 360) * (2 * Pi * Radius)
End Function
Function SectorArea(ByVal angle As Integer, ByVal Radius As Integer) As Double
SectorArea = (Pi * (Radius ^ 2) * angle) / 360
End Function
Function SegmentArea(ByVal angle As Integer, ByVal Radius As Integer) As Double
SegmentArea = ((Pi * (Radius ^ 2) * angle) / 360) - ((0.5 * (Radius ^ 2) * Sin(DegToRad(angle))))
End Function
Function TriangleNum(ByVal Num As Integer) As Integer
TriangleNum = (Num + 1) * (Num / 2)
End Function
Function SquareNum(ByVal Num As Integer) As Integer
SquareNum = Num ^ 2
End Function
Function CubeNum(ByVal Num As Integer) As Integer
CubeNum = Num ^ 3
End Function
Function AreaTriangleReg(ByVal Base As Integer, ByVal Height As Integer) As Double
AreaTriangleReg = (Base * Height) / 2
End Function
Function AreaTriangleIrreg(ByVal Side1 As Integer, ByVal Side2 As Integer, ByVal Angle1 As Integer) As Long
AreaTriangleIrreg = (1 / 2 * (Side1 * Side2 * (Sin(DegToRad(Angle1)))))
End Function
Function AreaTrapezium(ByVal TopWidth As Integer, ByVal BottomWidth As Integer, ByVal Height As Integer) As Double
AreaTrapezium = ((BottomWidth + TopWidth) * Height) / 2
End Function
Function CylinderVol(ByVal Radius As Integer, ByVal Length As Integer) As Double
CylinderVol = Pi * (Radius ^ 2) * Length
End Function
Function SphereVolume(ByVal Radius As Integer) As Double
SphereVolume = (4 / 3 * (Pi * (Radius ^ 3)))
End Function
Function SphereSurface(ByVal Radius As Integer) As Double
SphereVolume = (4 * Pi * (Radius ^ 2))
End Function
Function ConeVolume(ByVal Radius As Integer, ByVal Height As Integer) As Double
ConeVolume = (1 / 3 * (Pi * (Radius ^ 2 * (Height))))
End Function
Function ConeSurface(ByVal Radius As Integer, ByVal Length As Integer) As Double
ConeSurface = (Pi * (Radius ^ 2)) + (Pi * Radius * Length)
End Function
Function CosineRule(ByVal Side1 As Integer, ByVal Side2 As Integer, ByVal Angle1 As Integer) As Double
CosineRule = Sqr((Side1 ^ 2) + (Side2 ^ 2) - 2 * Side1 * Side2 * Cos(DegToRad(Angle1)))
End Function
Function LCM(ByVal Num1 As Integer, ByVal Num2 As Integer) As Integer
'Function returns lowest common multiple of two numbers
Dim MultipleCount As Integer
Dim NewTest As Integer
Dim Larger As Integer
LCM = 0
If Num1 > Num2 Then
Larger = 1
Else
Larger = 2
End If
If Larger = 1 Then
MultipleCount = 0
Do
MultipleCount = MultipleCount + 1
NewTest = Num1 * MultipleCount
If NewTest Mod Num2 = 0 Then LCM = NewTest
Loop Until LCM <> 0
Else
MultipleCount = 0
Do
MultipleCount = MultipleCount + 1
NewTest = Num2 * MultipleCount
If NewTest Mod Num1 = 0 Then LCM = NewTest
Loop Until LCM <> 0
End If
End Function