Der CType-Operator in VB 2005 Erstellung von Klassen, die wie integrierte Datentypen verwendet werden können.
Autor:   Manfred Bohn	Bewertung:	Views:  11.014
ohne Homepage	System:  WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	kein Beispielprojekt

Durch den CType-Operator lassen sich in VB 2005 Klassen erstellen, die im Code wie integrierte Datentypen verwendet werden können.

Als Beispiel dient die Klasse 'cDouble'.
Diese Klasse kapselt einen Double-Wert und stellt Operatoren für die vier Grundrechenarten zur Verfügung. Da in VB.Net die IEEE-kompatiblen Gleitkomma-Variablen (SINGLE, DOUBLE) keine Ausnahme auslösen, wenn es zu einem Überlauf oder einer Division durch 0 kommt, ist in diesen Fällen die Ausnahme 'Overflow' - entsprechend dem 'klassischen' VB-Verhalten - in 'cDouble' wieder integriert worden ('DivideByZero' wird jedoch ebenfalls als 'Overflow' gemeldet).

Durch geeignete Belegung der klassenglobalen Konstanten 'cMinValue' und 'cMaxValue' kann der akzeptierte Wertebereich der cDouble-Instanzen weiter eingegrenzt werden.
Dies ist nützlich bei der Modellierung. Hat man z.B. Variable, die Temperatur-Angaben enthalten sollen, ist es vermutlich zweckmäßig, den Wertebereich dieser Klasse von Variablen auf +/-50 einzugrenzen.

Die Vergleichsoperatoren der Klasse 'cDouble' führen ausprägungsabhängige Epsilon-Vergleiche durch. Welches Werteintervall dabei als 'gleich' akzeptiert wird, kann durch die klassenglobale Konstante 'cEpsilon' gesteuert werden.

Die Routine 'cDouble_Demo' zeigt die Verwendung der Klasse 'cDouble' im VB-Code.

Man beachte, dass weder das Schlüsselwort NEW bei der Erstellung eines Instanz, noch die explizite Konvertierung von numerischen Datentypen bei der Zuweisung erforderlich ist. Nur bei Zuweisung einer String-Variable mit numerisch darstellbarem Inhalt ist eine Konvertierung nötig (wegen 'OPTION STRICT ON').

Die mathematischen Funktionen in der Klasse MATH können von cDouble-Instanzen direkt verwendet werden. Falls man das Funktions-Ergebnis wieder auf eine cDouble-Instanz zuweist, wird beim Auftreten von IEEE-Sonderwerten der Overflow-Error ausgelöst.

Auch (z.B. mehrdimensionale) Arrays können aus Instanzen der Klasse 'cDouble' gebildet werden und sind im Code wie Double-Arrays verwendbar.

' =======================================================
' Klasse kapselt einen Double-Wert
' Fehler Overflow bei Wertebereichs-überschreitung 
' Verhalten imitiert integrierten VB-Datentyp
' =======================================================
' Mai 2007
' Manfred Bohn für VBARCHIV
 
Option Strict On
Option Explicit On
 
Public Class cDouble
 
  ' gekapselter Double-Wert
  Dim gDouble As Double
 
  ' zugelassene Werte-Limits:
  ' hier können auch bei Bedarf engere
  ' Beschränkungen vorgegeben werden
  Shared cMaxValue As Double = Double.MaxValue
  Shared cMinValue As Double = Double.MinValue
 
  ' relatives Epsilon für Wertvergleiche
  Shared cEpsilon As Double = 0.000001

  ' ================================================
  ' Konstruktoren
  ' ================================================
  Public Sub New()
    ' Standardkonstruktor 
    gDouble = 0.0
  End Sub
 
  Public Sub New(ByVal dbl As Double)
    ' Konstruktor mit Zuweisungsfunktion
    ' Initialisierung
    gDouble = 0.0
    Let_Value(dbl)
  End Sub

  ' ================================================
  ' Wertabfrage und Zuweisung (explizit)
  ' ================================================
  Public Sub Let_Value(ByVal dbl As Double)
    If Not CheckDouble(dbl) Then
      ' nur zugelassene Werte akzeptieren
      Throw New System.OverflowException
    Else
      ' Zuweisung
      gDouble = dbl
    End If
  End Sub
 
  Public Function Get_Value() As Double
    ' Wert-Abfrage
    Return gDouble
  End Function

  ' ====================================================
  ' klassenglobal vereinbarte Limits der Werteausprägung
  ' ====================================================
  Public Shared ReadOnly Property MinValue() As Double
    Get
      Return cMinValue
    End Get
  End Property
 
  Public Shared ReadOnly Property MaxValue() As Double
    Get
      Return cMaxValue
    End Get
  End Property

  ' ======================================================
  ' Limitüberprüfung (angewendet bei allen Parametern)
  ' ======================================================
  Private Shared Function CheckDouble(ByVal dbl As Double) As Boolean
    ' Wertebereich des Double prüfewn und 
    ' ggf. Fehler auslösen
 
    ' Durch diese Abfrage werden Infinity/Nan-Werte
    ' erkannt, ohne dass auf die entsprechenden 
    ' Double-Methoden 'IsNan', 'IsInfinity' 
    ' zurückgegriffen werden muss
    If dbl <= cMaxValue And _
      dbl >= cMinValue Then
      Return True
    Else
      Return False
    End If
  End Function

  Public Shared Widening Operator CType( _
    ByVal cdb As cDouble) As Double
 
    ' beliebige numerische Datentypen 
    ' können den Inhalt der Instanz von 
    ' cDouble aufnehmen, falls numerisch möglich
    ' ggf. nach impliziter Konvertierung
    Return cdb.Get_Value
  End Operator
 
  Public Shared Widening Operator CType( _
    ByVal dbl As Double) As cDouble
 
    ' beliebige numerische Werte können
    ' falls numerisch zulässig - in eine (neue) Instanz 
    ' von cDouble eingetragen werden (als Double-Wert)
    Dim erg As New cDouble(dbl)
    Return erg
  End Operator

  ' =========================================================
  ' Vergleichsoperatoren (Epsilon-Vergleich !!)
  ' =========================================================
  Public Shared Operator =( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As Boolean
 
    ' Epsilon-Vergleich von 2 Werten
    Return IsEqual(cdb1.Get_Value, cdb2.Get_Value)
  End Operator
 
  Public Shared Operator <>( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As Boolean
 
    Return (Not IsEqual(cdb1.Get_Value, cdb2.Get_Value))
  End Operator
 
  Public Shared Operator >( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As Boolean
 
    If Not IsEqual(cdb1.Get_Value, cdb2.Get_Value) Then
      Return cdb1.Get_Value > cdb2.Get_Value
    Else
      Return False
    End If
  End Operator
 
  Public Shared Operator <( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As Boolean
 
    If Not IsEqual(cdb1.Get_Value, cdb2.Get_Value) Then
      Return cdb1.Get_Value < cdb2.Get_Value
    Else
      Return False
    End If
  End Operator
 
  Public Shared Operator >=( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As Boolean
 
    If IsEqual(cdb1.Get_Value, cdb2.Get_Value) Then
      Return True
    Else
      Return cdb1 > cdb2
    End If
  End Operator
 
  Public Shared Operator <=( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As Boolean
 
    If IsEqual(cdb1.Get_Value, cdb2.Get_Value) Then
      Return True
    Else
      Return cdb1 < cdb2
    End If
  End Operator

  Private Shared Function IsEqual(ByVal dbl1 As Double, _
    ByVal dbl2 As Double) As Boolean
 
    ' allgemeine Hilfsfunktion: Vergleichsoperatoren 
    ' Epsilon-Vergleich von 2 Double-Werten
 
    Dim Min_Eps As Double = Double.Epsilon * 10
    Dim eps As Double = _
      cEpsilon * Math.Max(Math.Abs(dbl1), Math.Abs(dbl2))
 
    If eps < Min_eps Then eps = Min_Eps
    If dbl1 > eps And dbl2 < -eps Then
      Return False
    ElseIf dbl1 < -eps And dbl2 > eps Then
      Return False
    Else
      Return Math.Abs(dbl1 - dbl2) <= eps
    End If
  End Function

  ' ===========================================================
  ' Arithmetische Operatoren
  ' ===========================================================
  Public Shared Operator +( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As cDouble
 
    Dim erg As New cDouble
    erg.Let_Value(cdb1.Get_Value + cdb2.Get_Value)
    Return erg
  End Operator
 
  Public Shared Operator -( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As cDouble
 
    Dim erg As New cDouble
    erg.Let_Value(cdb1.Get_Value - cdb2.Get_Value)
    Return erg
  End Operator
 
  Public Shared Operator *( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As cDouble
 
    Dim erg As New cDouble
    erg.Let_Value(cdb1.Get_Value * cdb2.Get_Value)
    Return erg
  End Operator
 
  Public Shared Operator /( _
    ByVal cdb1 As cDouble, _
    ByVal cdb2 As cDouble) As cDouble
 
    Dim erg As New cDouble
    erg.Let_Value(cdb1.Get_Value / cdb2.Get_Value)
    Return erg
 
  End Operator

End Class
' =================================================================
' Ende der Klasse 'cDouble'
' =================================================================

Demonstrationsroutine

Public Sub cDouble_Demo()
  ' Routine zur Demonstration der Klasse 'cDouble'
 
  Dim lng1, lng2 As Long               ' Long
  Dim str_lng As String                ' String-Variable
  Dim dbl1, dbl2, dbl_erg As Double    ' Double
 
  Dim cdb1, cdb2, cdbl_erg As cDouble  ' cDouble-Instanzen
 
  Dim dbl_arr(,) As Double             ' Double-Array 
  Dim cdb_arr(,) As cDouble            ' cDouble-Array
 
  Dim i As Integer                     ' Loop
  Dim d1, d2 As Integer                ' Array-Loops
 
  ' Test-Durchläufe
  For i = 1 To 1000000
 
    ' 2 zufällige Double-Werte
    dbl1 = Random_Double()
    dbl2 = Random_Double()
    If dbl2 = 0 Then dbl2 = 1 ' 0 vermeiden
 
    ' Manchmal sind beide Werte gleich
    If i Mod 100 = 0 Then dbl2 = dbl1
 
    ' Zuweisung der Zufallswerte auf cDouble-Instanzen
    cdb1 = dbl1
    cdb2 = dbl2
 
    ' typreine Additionen und Ergebnisvergleich
    cdbl_erg = cdb1 + cdb2
    dbl_erg = dbl1 + dbl2
    If dbl_erg <> cdbl_erg Then Stop
 
    ' typgemischte Subtraktionen und Ergebnisvergleich
    cdbl_erg = cdb1 + dbl2
    dbl_erg = dbl1 + cdb2
    If dbl_erg <> cdbl_erg Then Stop
 
    ' typreine Multiplikation
    cdbl_erg = cdb1 * cdb2
    dbl_erg = dbl1 * dbl2
    If dbl_erg <> cdbl_erg Then Stop
 
    If Math.Abs(dbl2) > 0 Then
      ' typgemischte Divisionen und Ergebnisvergleich
      cdbl_erg = dbl1 / cdb2
      dbl_erg = cdb1 / dbl2
      If dbl_erg <> cdbl_erg Then Stop
    End If
 
    ' Vergleichsoperatoren:
    ' Double-Vergleich muss cDouble-Vergleich entsprechen 
    If (dbl1 > dbl2) <> (cdb1 > cdb2) Then Stop
    If (dbl1 < dbl2) <> (cdb1 < cdb2) Then Stop
 
    If (dbl1 >= dbl2) <> (cdb1 >= cdb2) Then Stop
    If (dbl1 <= dbl2) <> (cdb1 <= cdb2) Then Stop
 
    If (dbl1 <> dbl2) <> (cdb1 <> cdb2) Then Stop
    If (dbl1 = dbl2) <> (cdb1 = cdb2) Then Stop
 
    ' Verwendung von MATH-Funktionen
    If Math.Sqrt(Math.Abs(dbl1)) <> _
      Math.Sqrt(Math.Abs(cdb1)) Then Stop
    If Math.Pow(Math.Abs(dbl1), 0.55) <> _
      Math.Pow(Math.Abs(cdb1), 0.55) Then Stop
    If Math.Round(dbl1, 5) <> _
      Math.Round(cdb1, 5) Then Stop
    If Math.Truncate(dbl1) <> _
      Math.Truncate(cdb1) Then Stop
 
    ' 2 zufällige Long-Werte
    lng1 = CLng(10000 * Rnd())
    lng2 = CLng(1000000 * Rnd())
    If lng2 = 0 Then lng2 = 1 ' 0 vermeiden
 
    ' Umwandlung in einen String
    str_lng = CStr(lng1)
 
    ' Zuweisung eines numerischen Strings auf cDouble
    cdb1 = CDbl(str_lng)
 
    ' Zuweisung eines Long-Wertes auf cDouble
    cdb2 = lng2
 
    ' Ergebnisvergleich nach typgemischter Addition 
    If lng1 + cdb2 <> cdb2 + lng1 Then Stop
    If lng1 / cdb2 <> cdb1 / lng2 Then Stop
 
    ' cDouble-Array
    ReDim cdb_arr(10, 20)
    ' Double-Array
    ReDim dbl_arr(UBound(cdb_arr, 1), UBound(cdb_arr, 2))
 
    For d1 = 0 To UBound(cdb_arr, 1)
      For d2 = 0 To UBound(cdb_arr, 2)
        ' Arrays füllen
        cdb_arr(d1, d2) = Rnd()
        dbl_arr(d1, d2) = cdb_arr(d1, d2)
      Next d2
    Next d1
 
    cdb1 = 0 : cdb2 = 0 ' für Summation
    For d1 = 0 To UBound(cdb_arr, 1)
      For d2 = 0 To UBound(cdb_arr, 2)
        ' Inhalt der Arrays vergleichen
        If cdb_arr(d1, d2) <> dbl_arr(d1, d2) Then Stop
        ' Summation der Felder in cDouble-Instanzen
        cdb1 += cdb_arr(d1, d2)
        cdb2 += dbl_arr(d1, d2)
      Next d2
    Next d1
 
    ' Vergleich der Feld-Summen beider Arrays
    If cdb1 <> cdb2 Then Stop
 
    ' nächster Durchlauf
  Next i
End Sub

Public Function Random_Double() As Double
  ' zufälliger Double-Wert im Bereich 
  ' -1E30 bis +1E30
 
  Dim x As Double = Rnd() * 1.0E+30
  If Rnd() > 0.5 Then x = -x
  Return x
End Function

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.