Füllen eines UDT's Füllen eines UDT's (user defined type) mit für den Datentyp gültigen Werten
Autor:   Norbert Grimm	Bewertung:     [ Jetzt bewerten ]	Views:  8.796
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 8 Bewertung insgesamt: gut Durchschnittliche Bewertung: 4.4 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Die Funktion CVTyp wandelt einen beliebigen an sie übergebenen Wert in einen für den Datentyp gültigen Wert (Rückgabewert).

' Test-UDT
Private Type vb_Variable
  nBool       As Boolean
  nInteger    As Integer
  nLong       As Long
  nSingle     As Single
  nDouble     As Double
  dDate       As Date
  sString     As String * 25
End Type

' TestAufruf
' Füllen eines UDT's (user defined type) mit
' für den Datentyp gültigen Werten
Private Function ConvVariable() As Integer
  Dim CV       As Long
  Dim udtWert  As vb_Variable
  Dim vArray() As Variant
  Dim V        As Variant
 
  On Error GoTo Err_CV
 
  ' TestArray
  vArray = Array(True, 999, 99999999, 99.9, "25.02.2008", "vb@rchiv", "")
 
  With udtWert
    CV = CVTyp(.nBool, vArray(0))
    CV = CVTyp(.nInteger, vArray(1))
    CV = CVTyp(.nLong, vArray(2))
    CV = CVTyp(.nSingle, vArray(3))
    CV = CVTyp(.nDouble, vArray(4)) ' XIn: ein DatumsType
    CV = CVTyp(.dDate, vArray(4))
    CV = CVTyp(.sString, vArray(5))
  End With
 
  MsgBox vArray(4) & vbCr & udtWert.nDouble & _
   vbCr & vbCr & vArray(5) & vbCr & udtWert.sString, _
   vbInformation, "TestAufruf" & Space(50)
 
  With udtWert
    CV = CVTyp(.nBool, vArray(6)) ' XIn: ""
  End With
 
  MsgBox vArray(6) & vbCr & udtWert.nBool, _
    vbInformation, "TestAufruf" & Space(50)
 
  With udtWert
    CV = CVTyp(.sString, V) ' XIn: leer oder NULL
  End With
 
  MsgBox "[leer oder NULL]" & vbCr & udtWert.sString, _
    vbInformation, "TestAufruf" & Space(50)
 
Exit_CV:
  Exit Function
 
Err_CV:
  MsgBox Err & vbCr & Err.Description, vbInformation, "ConvVariable"
  Resume Exit_CV
End Function

' Datentypische Umwandlung eines beliebigen Wertes
Function CVTyp(XOut As Variant, XIn As Variant) As Long
  Dim XVal As Variant
  Dim XTyp As Integer
 
  On Error GoTo Err_CVTyp
 
  ' check den VariablenTyp des Rückgabewertes (XOut)
  XTyp = VarType(XOut)
 
  ' Selektion an Hand des DatenTyps
  ' und datentypische Umwandlung des Einganswertes (XIn)
  Select Case XTyp
    Case vbBoolean
      If XIn > "" Then
        XVal = CBool(XIn)
      Else
        XVal = False
      End If
 
    Case vbInteger
      XVal = CInt(Val(XIn))
 
    Case vbLong
      XVal = CLng(Val(XIn))
 
    Case vbDate
      If Not IsDate(XIn) Then XIn = Now
      XVal = CDate(XIn)
 
    Case vbSingle
      If Not IsNumeric(XIn) Then XIn = 0
      XVal = CSng(XIn)
 
    Case vbDouble
      If Not IsNumeric(XIn) Then XIn = 0
      XVal = CDbl(XIn)
 
    Case vbString
      If IsNull(XIn) Then XIn = ""
      XVal = CStr(XIn)
 
    Case vbUserDefinedType
 
    Case Else
      XVal = ""
  End Select
 
  XOut = XVal
  CVTyp = XTyp
 
Exit_CVTyp:
  Exit Function
 
Err_CVTyp:
  XOut = 0
  MsgBox Err & vbCr & Err.Description, vbCritical, "CVTyp"
  Resume Exit_CVTyp
End Function