1. Herfried K. Wagner’s VB.Any
  2. Visual Basic
  3. Code

Mathematik und Geometrie

Ermitteln von Zufallszahlen in angegebenem Intervall

Um ganzzahlige Zufallszahlen in einem angegebenen Intervall zu ermitteln, kann folgende Funktion verwendet werden. Dabei wird der von der Funktion Rnd zurückgegebene Wert über dem Intervall skaliert:

Private Function GetRandomNumber( _
    ByVal Minimum As Long, _
    ByVal Maximum As Long _
) As Long
    GetRandomNumber = Rnd * (Maximum - Minimum) + Minimum
End Function

Ermitteln des größten gemeinsamen Teilers zweier Zahlen

Die folgende Funktion berechnet den größten gemeinsamen Teiler zweier Zahlen und gibt ihn zurück:

'
' Calculates the greatest common divider for two numbers.
'
Private Function GCD( _
    ByVal Number1 As Long, _
    ByVal Number2 As Long _
) As Long
    
    ' Sort numbers, after this call 'Number2' contains the
    ' larger number of the two numbers, 'Number1' the smaller
    ' one.
    If Number2 < Number1 Then
        Dim n As Long
        
        n = Number2
        Number2 = Number1
        Number1 = n
    End If
    
    ' 'Number1' contains the smallest number. The first two
    ' statements inside the loop will change this and place the
    ' value of 'Remainder' in 'Number2'.  Which is supposed
    ' to be the smallest.
    Dim Remainder As Long
    Remainder = Number1
    Do While Remainder > 1
        
        ' The remainder of the division is always the smallest
        ' number and thus must be stored in 'Number2'.
        Number1 = Number2
        Number2 = Remainder
        Remainder = Number1 Mod Number2
    Loop
    
    ' Return value.
    If Remainder = 0 Then
        GCD = Number2
    Else
        GCD = Remainder
    End If
End Function

Ungenaues Berechnen von π

Bei mathematischen Berechnungen, beispielsweise in der Trigonometrie, benötigt man oft den Wert der Kreiszahl π. Dieser kann in meist ausreichender Genauigkeit über die im Folgenden angegebene kleine Funktion berechnet werden. Sinnvollerweise sollte π nur ein Mal berechnet und dann wiederverwendet werden, damit die Laufzeit des Programms verbessert werden kann:

Private Function CalcPi() As Double
    CalcPi = 4 * Atn(1)
End Function

Ziehen beliebiger Wurzeln

Die meisten Programmiersprachen stellen eine Funktion zur Berechnung der Quadratwurzel einer Zahl zur Verfügung. Zur Berechnung der x-ten Wurzel aus einer Zahl kann man darauf zurückgreifen, daß die x-te (Wurzelexponent) Wurzel aus y (Radikand) gleich y1x ist. Dies läßt sich leicht in eine eigene Funktion namens Root packen:

Private Function Root( _
    ByVal Radicand As Double, _
    ByVal RootExponent As Double _
) As Double
    Root = Radicand ^ (1 / RootExponent)
End Function

Die Funktion Root zieht also die RootExponent-te Wurzel aus Radicand und gibt das Ergebnis zurück. Der Aufruf könnte dann folgendermaßen erfolgen:

Result = 0.25 + Root(16, a) * 4711

Es ist zu beachten, daß das Ziehen der Quadratwurzel aus einer Zahl über die Visual Basic-eigene Sqr-Funktion bedeutend schneller durchgeführt wird, als von der oben beschriebenen Funktion Root.

Umwandeln einer Zahl in eine Binärzeichenfolge

Um eine Zahl in einen Binärstring, bestehend aus den Zeichen „0“, „1“ und „-“ umzuwandeln, bietet sich diese rekursive Funktion an. Die Funktion behandelt keine Vorzeichenbits, sondern fügt der Zahl an erster Stelle ein Minus hinzu, wenn es sich um eine negative Zahl handelt:

Private Function DecToBin(ByVal Number As Long) As String
    If Abs(Number) > 1 Then
        DecToBin = DecToBin(Number \ 2) & CStr(Abs(Number Mod 2))
    Else
        DecToBin = CStr(Number)
    End If
End Function

Ein möglicher Aufruf könnte wie folgt aussehen:

Debug.Print DecToBin(1982)
Debug.Print DecToBin(-4711)

Eine iterative Version könnte so aussehen:

Private Function DecToBin(ByVal Number As Long) As String
    Dim Absolute As Long
    Absolute = Abs(Number)
    If Absolute >= 2 ^ 31 Then
        DecToBin = "OVERFLOW"
    Else
        Dim i As Long
        Absolute = Abs(Number)
        Do
            If (Absolute And 2 ^ i) = 2 ^ i Then
                DecToBin = "1" & DecToBin
            Else
                DecToBin = "0" & DecToBin
            End If
            i = i + 1
        Loop Until 2 ^ i > Absolute
    End If
    If Number < 0 Then
        DecToBin = "-" & DecToBin
    End If
End Function

Bestimmen von Minimum und Maximum in einem Array

Folgende Funktionen geben das Minimum und das Maximum in einem Array zurück. Das Eingangsarray ist als Variant deklariert, sodaß das Beispiel mit verschiedenen Elementdatentypen funktioniert (Min("Modem", "Harddisk", "Mouse", "Computer") = "Computer" und Min(3, -5, 0, 9) = -5). Die Funktionen verfügen über zwei Parameter, sodaß mindestens ein Wert an die Funktionen übergeben werden muß:

Private Sub Main()
    Call MsgBox( _
        "Min(""Modem"", ""Harddisk"", ""Mouse"", ""Computer"") = " & _
        """" & _
        Min("Modem", "Harddisk", "Mouse", "Computer") & _
        """" & vbNewLine & _
        vbNewLine & _
        "Max(""Modem"", ""Harddisk"", ""Mouse"", ""Computer"") = " & _
        """" & _
        Max("Modem", "Harddisk", "Mouse", "Computer") & _
        """" _
    )
    Call MsgBox( _
        "Min(3, -5, 0, 9) = " & _
        Min(3, -5, 0, 9) & vbNewLine & _
        vbNewLine & _
        "Max(3, -5, 0, 9) = " & _
        Max(3, -5, 0, 9) _
    )
End Sub

'
' Minimum bestimmen.
'
Private Function Min( _
    ByVal Item As Variant, _
    ParamArray Items() As Variant _
) As Variant
    Dim k As Long
    For k = 0 To UBound(Items)
        If Items(k) < Item Then
            Item = Items(k)
        End If
    Next k
    Min = Item
End Function

'
' Maximum bestimmen.
'
Private Function Max( _
    ByVal Item As Variant, _
    ParamArray Items() As Variant _
) As Variant
    Dim k As Long
    For k = 0 To UBound(Items)
        If Items(k) > Item Then
            Item = Items(k)
        End If
    Next k
    Max = Item
End Function