Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0714: Alle trigonometrischen / transzendenten Funktionen

 von 

Beschreibung 

Hier ein kleines Modul, welches alle trigonometrischen, bzw. transzendenten Funktionen incl. Test-Routinen und Grafikausgabe beinhaltet.

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

keine

Download:

Download des Beispielprojektes [5,92 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Kombinationsliste "CmbGrafikTest"
' Steuerelement: Bildfeld-Steuerelement "PBTrigo"
' Steuerelement: Schaltfläche "BtnTextTest"
' Steuerelement: Textfeld "TxtTrigo"
' Steuerelement: Beschriftungsfeld "LblGrafikTest"
Option Explicit

Private Sub Form_Load()
    Call FillCombo(CmbGrafikTest)
    Call BtnTextTest_Click
    PBTrigo.ScaleMode = 7 'cm
End Sub
Private Sub FillCombo(aCMB As ComboBox)
    Dim A: A = Array( _
    "Sinus", "Cosinus", "Tangens", _
    "Cosecans", "Secans", "Cotangens", _
    "ArcusSinus", "ArcusCosinus", "ArcusTangens", _
    "ArcusCosecans", "ArcusSecans", "ArcusCotangens", _
    "SinusHyperbolicus", "CosinusHyperbolicus", "TangensHyperbolicus", _
    "CosecansHyperbolicus", "SecansHyperbolicus", "CotangensHyperbolicus", _
    "AreaSinusHyperbolicus", "AreaCosinusHyperbolicus", "AreaTangensHyperbolicus", _
    "AreaCosecansHyperbolicus", "AreaSecansHyperbolicus", "AreaCotangensHyperbolicus", _
    "SinusCardinalis")
    Dim i As Long
    With aCMB
        .Clear
        For i = 0 To UBound(A)
            Call .AddItem(A(i))
        Next
    End With
    aCMB.Text = "Sinus"
End Sub

Private Sub CmbGrafikTest_Click()
    PBTrigo.ZOrder 0
    PBTrigo.Refresh
End Sub
'Private Sub CmbGrafikTest_Change()
'    PBTrigo.ZOrder 0
'    PBTrigo.Refresh
'End Sub

Private Sub BtnTextTest_Click()
    TxtTrigo.ZOrder 0
    Call TextTestTrigo
End Sub

Private Sub TextTestTrigo()
    Dim t As String
    t = t & TestTrigonoMath
    t = t & TestATAN
    t = t & TestAngleConverter
    t = t & TestLogarithm
    t = t & TestFloorCeilingBigMul
    TxtTrigo.Text = t
End Sub
Private Function TestTrigonoMath() As String
    Dim s As String
    Dim A As Double, r As Double
    
    s = s & "Test Trigono Math" & vbCrLf
    
    A = PI / 3
    
    r = ModTrigonoMath.Sinus(A)
    s = s & " Sinus(" & Format(RadToDeg(A), "0.0°") & ") = " & Format(r, "0.000") & vbCrLf
    
    r = ModTrigonoMath.Cosinus(A)
    s = s & " Cosinus(" & Format(RadToDeg(A), "0.0°") & ") = " & Format(r, "0.000") & vbCrLf
    
    r = ModTrigonoMath.Tangens(A)
    s = s & " Tangens(" & Format(RadToDeg(A), "0.0°") & ") = " & Format(r, "0.000") & vbCrLf
    
    r = ModTrigonoMath.Cosecans(A)
    s = s & " Cosecans(" & Format(RadToDeg(A), "0.0°") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.Secans(A)
    s = s & " Secans(" & Format(RadToDeg(A), "0.0°") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.Cotangens(A)
    s = s & " Cotangens(" & Format(RadToDeg(A), "0.0°") & ") = " & CStr(r) & vbCrLf
    
    A = 0.5
    r = ModTrigonoMath.ArcusSinus(A)
    s = s & " ArcusSinus(" & Format(A, "0.000") & ") = " & Format(RadToDeg(r), "0.0°") & vbCrLf

    r = ModTrigonoMath.ArcusCosinus(A)
    s = s & " ArcusCosinus(" & Format(A, "0.000") & ") = " & Format(RadToDeg(r), "0.0°") & vbCrLf
    
    A = Sqr(3)
    r = ModTrigonoMath.ArcusTangens(A)
    s = s & " ArcusTangens(" & Format(A, "0.000") & ") = " & Format(RadToDeg(r), "0.0°") & vbCrLf

    A = 1.5
    r = ModTrigonoMath.ArcusCosecans(A)
    s = s & " ArcusCosecans(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.ArcusSecans(A)
    s = s & " ArcusSecans(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.ArcusCotangens(A)
    s = s & " ArcusCotangens(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    
    r = ModTrigonoMath.SinusHyperbolicus(A)
    s = s & " SinusHyperbolicus(" & Format(RadToDeg(A), "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.CosinusHyperbolicus(A)
    s = s & " CosinusHyperbolicus(" & Format(RadToDeg(A), "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.TangensHyperbolicus(A)
    s = s & " TangensHyperbolicus(" & Format(RadToDeg(A), "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.CosecansHyperbolicus(A)
    s = s & " CosecansHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.SecansHyperbolicus(A)
    s = s & " SecansHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.CotangensHyperbolicus(A)
    s = s & " CotangensHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    A = 0.5
    r = ModTrigonoMath.AreaSinusHyperbolicus(A)
    s = s & " AreaSinusHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    A = 1.5
    r = ModTrigonoMath.AreaCosinusHyperbolicus(A)
    s = s & " AreaCosinusHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    A = 0.5
    r = ModTrigonoMath.AreaTangensHyperbolicus(A)
    s = s & " AreaTangensHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.AreaCosecansHyperbolicus(A)
    s = s & " AreaCosecansHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    r = ModTrigonoMath.AreaSecansHyperbolicus(A)
    s = s & " AreaSecansHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    A = 1.5
    r = ModTrigonoMath.AreaCotangensHyperbolicus(A)
    s = s & " AreaCotangensHyperbolicus(" & Format(A, "0.000") & ") = " & CStr(r) & vbCrLf
    
    TestTrigonoMath = s & vbCrLf
End Function

Private Function TestATAN() As String
    Dim s As String
    s = s & "Test ArcusTangensXY (aka Atan2)" & vbCrLf
    s = s & TestATANToString(0, 0)
    s = s & TestATANToString(1.5, 0)
    s = s & TestATANToString(0, 1.5)
    s = s & TestATANToString(1.2, 1.5)
    s = s & TestATANToString(-1.5, 0)
    s = s & TestATANToString(0, -1.5)
    s = s & TestATANToString(-1.2, -1.5)
    s = s & TestATANToString(1.2, -1.5)
    s = s & TestATANToString(-1.2, 1.5)
    TestATAN = s & vbCrLf
End Function
Private Function TestATANToString(ByVal x As Double, _
                                  ByVal y As Double) As String
    Dim A As Double
    Dim s As String
    A = ArcusTangensXY(x, y)
    s = s & " ArcusTangensXY(x := " & _
       Format$(x, "0.0") & "; y := " & Format$(x, "0.0") & ") = " & _
       Format$(A, "0.000") & vbCrLf
    TestATANToString = s
End Function
Public Function TestAngleConverter() As String

    Dim angleD As Double ' Winkel in Grad
    Dim angleR As Double ' Winkel in Radians
    Dim angleG As Double ' Winkel in Gon

    angleD = 180#

    angleR = DegToRad(angleD)
    angleG = DegToGon(angleD)

    angleD = RadToDeg(angleR)
    angleG = RadToGon(angleR)

    angleD = GonToDeg(angleG)
    angleR = GonToRad(angleG)

    ' 180 3,14159265358979 200
    TestAngleConverter = "Test Winkelkonvertierung: " & vbCrLf & _
        " Angle [deg] = " & Format$(angleD, "0.0") & vbCrLf & _
        " Angle [rad] = " & Format$(angleR, "0.00000") & vbCrLf & _
        " Angle [gon] = " & Format$(angleG, "0.0") & vbCrLf

End Function

Public Function TestLogarithm() As String

    Dim s As String
    Dim x As Double
    Dim b As Double
    Dim N As Double
    Dim L As Double

    s = s & vbCrLf & "Test Logarithmus: " & vbCrLf

    x = 10000
    b = 10
    L = LogN(x, b)
    s = s & " LogN(" & CStr(x) & ", " & CStr(b) & ") = " & CStr(L) & vbCrLf

    b = 5
    L = LogN(x, b)
    s = s & " LogN(" & CStr(x) & ", " & CStr(b) & ") = " & CStr(L) & vbCrLf

    b = 4
    L = LogN(x, b)
    s = s & " LogN(" & CStr(x) & ", " & CStr(b) & ") = " & CStr(L) & vbCrLf

    N = 2
    L = LogN(x, N)
    s = s & " LogN(" & CStr(x) & ", " & CStr(N) & ") = " & CStr(L) & vbCrLf

    ' N = 10
    L = LogN(x)
    s = s & " LogN(" & CStr(x) & ") = " & CStr(L) & vbCrLf

    ' N = 10
    L = Log10(x) ' , N)
    s = s & " Log10(" & CStr(x) & ") = " & CStr(L) & vbCrLf
    
    x = 2
    L = LN(x)
    s = s & " Ln(" & CStr(x) & ") = " & CStr(L) & vbCrLf
    
    ' N = 1
    L = LogN(x, 2)
    s = s & " LogN(" & CStr(x) & ") = " & CStr(L) & vbCrLf
    TestLogarithm = s

End Function
Private Function TestFloorCeilingBigMul() As String
    Dim s As String
    Dim d As Double
    s = s & vbCrLf & "Test Floor, Ceiling, BigMul" & vbCrLf
    
    d = 2147483649.12345
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    d = 2147483649.56789
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    d = 1#
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    d = 0#
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    d = -1#
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    d = -2147483649.12345
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    d = -2147483649.56789
    s = s & MessDFC(d, Floor(d), Ceiling(d))
    
    Dim dec
    dec = BigMul(999999999#, 999999999#)
    s = s & " BigMul(999999999, 999999999) = " & CStr(dec)
    TestFloorCeilingBigMul = s
End Function
Private Function MessDFC(ByVal d As Double, _
                         ByVal f As Double, _
                         ByVal c As Double) As String
    MessDFC = "   Floor(" & CStr(d) & ") = " & CStr(f) & vbCrLf & _
              " Ceiling(" & CStr(d) & ") = " & CStr(c) & vbCrLf
End Function
Private Sub PBTrigo_Paint()
'is rather quick'n'dirty
'soll nur zum Testen der Funktionen dienen
    On Error Resume Next
    Dim X1 As Double, Y1 As Double
    Dim X2 As Double, Y2 As Double
    Dim XN As Double, YN As Double
    
    'die Koordinaten des Nullpunkts (zur Verschiebung)
    XN = PBTrigo.ScaleWidth / 2
    YN = PBTrigo.ScaleHeight / 2
    'Koordinatensystem zeichnen
    'die X-Achse zeichnen
    X1 = 0:                  Y1 = YN
    X2 = PBTrigo.ScaleWidth: Y2 = Y1
    PBTrigo.Line (X1, Y1)-(X2, Y2)
    'die Y-Achse zeichnen
    X1 = XN: Y1 = 0
    X2 = X1: Y2 = PBTrigo.ScaleHeight
    PBTrigo.Line (X1, Y1)-(X2, Y2)
    
    'Kurve zeichnen
    Dim i As Long
    Dim DrawItem As String
    DrawItem = CmbGrafikTest.Text
    ReDim Pts(0 To 720) As Double 'zwei Perioden zeichnen -pi...0...+pi
    Dim p As Double
    'Array füllen
    For i = 0 To UBound(Pts)
        p = CDbl(DegToRad(i - 360))
        Select Case DrawItem 'DrawItem
        'Trigonometrische Funktionen
        Case "Sinus"
            Pts(i) = ModTrigonoMath.Sinus(p)
        Case "Cosinus"
            Pts(i) = ModTrigonoMath.Cosinus(p)
        Case "Tangens"
            Pts(i) = ModTrigonoMath.Tangens(p)
        Case "Cosecans"
            Pts(i) = ModTrigonoMath.Cosecans(p)
        Case "Secans"
            Pts(i) = ModTrigonoMath.Secans(p)
        Case "Cotangens"
            Pts(i) = ModTrigonoMath.Cotangens(p)
        'Trigonometrische Umkehrfunktionen
        Case "ArcusSinus"
            Pts(i) = ModTrigonoMath.ArcusSinus(p)
        Case "ArcusCosinus"
            Pts(i) = ModTrigonoMath.ArcusCosinus(p)
        Case "ArcusTangens"
            Pts(i) = ModTrigonoMath.ArcusTangens(p)
        Case "ArcusCosecans"
            Pts(i) = ModTrigonoMath.ArcusCosecans(p)
        Case "ArcusSecans"
            Pts(i) = ModTrigonoMath.ArcusSecans(p)
        Case "ArcusCotangens"
            Pts(i) = ModTrigonoMath.ArcusCotangens(p)
        'Hyperbolische Funktionen
        Case "SinusHyperbolicus"
            Pts(i) = ModTrigonoMath.SinusHyperbolicus(p)
        Case "CosinusHyperbolicus"
            Pts(i) = ModTrigonoMath.CosinusHyperbolicus(p)
        Case "TangensHyperbolicus"
            Pts(i) = ModTrigonoMath.TangensHyperbolicus(p)
        Case "CosecansHyperbolicus"
            Pts(i) = ModTrigonoMath.CosecansHyperbolicus(p)
        Case "SecansHyperbolicus"
            Pts(i) = ModTrigonoMath.SecansHyperbolicus(p)
        Case "CotangensHyperbolicus"
            Pts(i) = ModTrigonoMath.CotangensHyperbolicus(p)
        'Hyperbolische Umkehrfunktionen
        Case "AreaSinusHyperbolicus"
            Pts(i) = ModTrigonoMath.AreaSinusHyperbolicus(p)
        Case "AreaCosinusHyperbolicus"
            Pts(i) = ModTrigonoMath.AreaCosinusHyperbolicus(p)
        Case "AreaTangensHyperbolicus"
            Pts(i) = ModTrigonoMath.AreaTangensHyperbolicus(p)
        Case "AreaCosecansHyperbolicus"
            Pts(i) = ModTrigonoMath.AreaCosecansHyperbolicus(p)
        Case "AreaSecansHyperbolicus"
            Pts(i) = ModTrigonoMath.AreaSecansHyperbolicus(p)
        Case "AreaCotangensHyperbolicus"
            Pts(i) = ModTrigonoMath.AreaCotangensHyperbolicus(p)
        'Spezielle Funktionen
        Case "SinusCardinalis"
            Pts(i) = ModTrigonoMath.SinusCardinalis(p * 2 * PI) * 4
        End Select
    Next
    'Kurve in Array zeichnen
    For i = LBound(Pts) To UBound(Pts) - 1
        X1 = (-2 * PI + i * PI / 180) + XN:       Y1 = -(Pts(i)) + YN
        X2 = (-2 * PI + (i + 1) * PI / 180) + XN: Y2 = -(Pts(i + 1)) + YN
        PBTrigo.Line (X1, Y1)-(X2, Y2)
    Next
  
End Sub

Private Sub Form_Resize()
    Dim L As Single, t As Single, w As Single, H As Single
    Dim brdr As Single
    brdr = 8 * 15
    L = brdr: t = TxtTrigo.Top
    w = Me.ScaleWidth - L - brdr
    H = Me.ScaleHeight - t - brdr
    If w > 0 And H > 0 Then
        Call TxtTrigo.Move(L, t, w, H)
        Call PBTrigo.Move(L, t, w, H)
        PBTrigo.Cls
        Call PBTrigo_Paint
    End If
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--- Anfang Modul "ModTrigonoMath" alias ModTrigonoMath.bas ---
Option Explicit
Public Const PI As Double = 3.14159265358979

'##########'            Trigonometrische Funktionen             '##########'
Public Function Sinus(ByVal A As Double) As Double   ' aka sin
    Sinus = VBA.Math.Sin(A)
End Function
Public Function Cosinus(ByVal A As Double) As Double ' aka cos
    Cosinus = VBA.Math.Cos(A)
End Function
Public Function Tangens(ByVal A As Double) As Double ' aka tan
    Tangens = VBA.Math.Tan(A)
End Function

Public Function Cosecans(ByVal A As Double) As Double  ' aka csc
    Cosecans = 1 / VBA.Math.Sin(A)
End Function
Public Function Secans(ByVal A As Double) As Double    ' aka sec
    Secans = 1 / VBA.Math.Cos(A)
End Function
Public Function Cotangens(ByVal A As Double) As Double ' aka cot
    Cotangens = 1 / VBA.Math.Tan(A)
End Function

'##########'         Trigonometrische Umkehrfunktionen          '##########'
Public Function ArcusSinus(ByVal y As Double) As Double   ' aka arcsin
    Select Case y
        Case 1
            ArcusSinus = 0.5 * PI
        Case -1
            ArcusSinus = -0.5 * PI
        Case Else
            ArcusSinus = VBA.Math.Atn(y / Sqr(1 - y * y))
    End Select
End Function
Public Function ArcusCosinus(ByVal x As Double) As Double ' aka arccos
    ArcusCosinus = 0.5 * PI - ArcusSinus(x)
End Function
Public Function ArcusTangens(ByVal t As Double) As Double ' aka arctan
    ArcusTangens = VBA.Math.Atn(t)
End Function

'ArcusTangensXY: also known as ATan2
Public Function ArcusTangensXY(ByVal x As Double, _
                               ByVal y As Double) As Double
    If y > 0 Then
        If x > 0 Then       ' 1. Quadrant
            ArcusTangensXY = Atn(Abs(y) / Abs(x)) '+ PI * 0#
        ElseIf x < 0 Then   ' 2. Quadrant
            ArcusTangensXY = -Atn(Abs(y) / Abs(x)) + PI '* 1#
        Else 'If x = 0 Then ' pos. Y-Achse
            ArcusTangensXY = 0.5 * PI
        End If
    ElseIf y < 0 Then
        If x < 0 Then       ' 3. Quadrant
            ArcusTangensXY = Atn(Abs(y) / Abs(x)) + PI '* 1#
        ElseIf x > 0 Then   ' 4. Quadrant
            ArcusTangensXY = -Atn(Abs(y) / Abs(x)) + PI * 2
        Else 'If x = 0 Then ' neg. Y-Achse
            ArcusTangensXY = 1.5 * PI
        End If
    Else 'If y = 0 Then
        If x > 0 Then       ' pos. X-Achse
            ArcusTangensXY = 0
        ElseIf x < 0 Then   ' neg. X-Achse
            ArcusTangensXY = PI
        Else 'If x = 0 Then ' Nullpunkt
            ArcusTangensXY = 0
        End If
    End If
End Function

Public Function ArcusCosecans(ByVal y As Double) As Double  ' aka arccsc
    ArcusCosecans = ArcusSinus(1 / y)
End Function
Public Function ArcusSecans(ByVal x As Double) As Double    ' aka arcsec
    ArcusSecans = ArcusCosinus(1 / x)
End Function
Public Function ArcusCotangens(ByVal t As Double) As Double ' aka arccot
    ArcusCotangens = PI * 0.5 - VBA.Math.Atn(t)
End Function

'######################'  Hyperbolische Funktionen   '#####################'
Public Function SinusHyperbolicus(ByVal A As Double) As Double   ' aka sinh
    SinusHyperbolicus = (Exp(A) - Exp(-A)) / 2
End Function
Public Function CosinusHyperbolicus(ByVal A As Double) As Double ' aka sinh
    CosinusHyperbolicus = (Exp(A) + Exp(-A)) / 2
End Function
Public Function TangensHyperbolicus(ByVal A As Double) As Double ' aka tanh
    TangensHyperbolicus = (Exp(A) - Exp(-A)) / (Exp(A) + Exp(-A))
End Function

Public Function CosecansHyperbolicus(ByVal y As Double) As Double  ' aka csch
    CosecansHyperbolicus = 2 / (Exp(y) - Exp(-y))
End Function
Public Function SecansHyperbolicus(ByVal x As Double) As Double    ' aka sech
    SecansHyperbolicus = 2 / (Exp(x) + Exp(-x))
End Function
Public Function CotangensHyperbolicus(ByVal t As Double) As Double ' aka coth
    CotangensHyperbolicus = (Exp(t) + Exp(-t)) / (Exp(t) - Exp(-t))
End Function

'##########'           Hyperbolische Umkehrfunktionen           '##########'
Public Function AreaSinusHyperbolicus(ByVal y As Double) As Double   ' aka arsinh
    AreaSinusHyperbolicus = VBA.Math.Log(y + Sqr(y * y + 1))
End Function
Public Function AreaCosinusHyperbolicus(ByVal x As Double) As Double ' aka arcosh
    AreaCosinusHyperbolicus = VBA.Math.Log(x + Sqr(x * x - 1))
End Function
Public Function AreaTangensHyperbolicus(ByVal t As Double) As Double ' aka artanh
    AreaTangensHyperbolicus = VBA.Math.Log((1 + t) / (1 - t)) / 2
End Function

Public Function AreaCosecansHyperbolicus(ByVal x As Double) As Double  ' aka arcsch
    AreaCosecansHyperbolicus = VBA.Math.Log((Sgn(x) * Sqr(x * x + 1) + 1) / x)
End Function
Public Function AreaSecansHyperbolicus(ByVal x As Double) As Double    ' aka arsech
    AreaSecansHyperbolicus = VBA.Math.Log((Sqr(-x * x + 1) + 1) / x)
End Function
Public Function AreaCotangensHyperbolicus(ByVal x As Double) As Double ' aka arcoth
    AreaCotangensHyperbolicus = VBA.Math.Log((x + 1) / (x - 1)) / 2
End Function


'##########'               Zusätzliche Funktionen               '##########'
Public Function SinusCardinalis(ByVal x As Double) As Double ' aka sinc
    If x = 0 Then
        SinusCardinalis = 1
    Else
        SinusCardinalis = VBA.Math.Sin(x) / x
    End If
End Function

Public Function Log10(ByVal d As Double) As Double
    Log10 = VBA.Math.Log(d) / VBA.Math.Log(10)
End Function
Public Function LN(ByVal d As Double) As Double
  LN = VBA.Math.Log(d)
End Function
Public Function LogN(ByVal x As Double, _
                     Optional ByVal N As Double = 10#) As Double
                     'n darf nicht eins und nicht 0 sein
    LogN = VBA.Math.Log(x) / VBA.Math.Log(N)
End Function

Public Function BigMul(ByVal A As Long, ByVal b As Long) As Variant
    BigMul = CDec(A) * CDec(b)
End Function

Public Function Floor(ByVal A As Double) As Double
    Floor = CDbl(Int(A))
End Function

Public Function Ceiling(ByVal A As Double) As Double
    Ceiling = CDbl(Int(A))
    If A <> 0 Then If Abs(Ceiling / A) <> 1 Then Ceiling = Ceiling + 1
End Function


'##########'    Winkelumrechnung    '##########'
' Grad(=Deg), Neugrad(=Gon) und Radians(=Rad)
Public Function DegToRad(ByVal A As Double) As Double
    DegToRad = A * PI / 180
End Function
Public Function DegToGon(ByVal A As Double) As Double
    DegToGon = A / 0.9
End Function
Public Function RadToDeg(ByVal A As Double) As Double
    RadToDeg = A * 180 / PI
End Function
Public Function RadToGon(ByVal A As Double) As Double
    RadToGon = A * 200 / PI
End Function
Public Function GonToDeg(ByVal A As Double) As Double
    GonToDeg = A * 0.9
End Function
Public Function GonToRad(ByVal A As Double) As Double
    GonToRad = A * PI / 200
End Function

'--- Ende Modul "ModTrigonoMath" alias ModTrigonoMath.bas ---
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von soundso am 23.05.2010 um 16:50

Die Atan2-Funktion ist in den verschiedenen aktuellen großen Frameworks (C, C++STL, Java, .NET) anders definiert. Wer Kompatibilität dazu braucht kann diesen Code verwenden:

Public Function Atan2(ByVal y As Double, ByVal x As Double) As Double
If x > 0 Then
'egal ob y > 0 oder y < 0 '1. Quadrant und 4. Quadrant
Atan2 = VBA.Math.Atn(y / x)
ElseIf x < 0 Then
If y > 0 Then '2. Quadrant
Atan2 = VBA.Math.Atn(y / x) + PI
ElseIf y < 0 Then '3. Quadrant
Atan2 = VBA.Math.Atn(y / x) - PI
Else 'neg x-Achse
Atan2 = PI
End If
Else
If y > 0 Then 'pos y-Achse
Atan2 = 0.5 * PI
ElseIf y < 0 Then 'neg y-Achse
Atan2 = -0.5 * PI
Else 'Nullpunkt
Atan2 = 0#
End If
End If
End Function

die Funktion unterschiedet sich in:
* die Parameter sind anders herum definiert als hier:
zuerst kommt y dann x
* liefert für negative y-Werte negative Winkel

Kommentar von soundso am 24.02.2010 um 09:36

Fehlerkorrektur
bei CosinusHyperbolicus steht hinter der Funktion eine falsche Abkürzung:
' aka sinh
richtig ist natürlich:
' aka cosh

Gruß
soundso