VB6 UDT Reflection

[yrwyddfa]

Write then.

I need to interrogate the structure of a UDT at runtime; the structure of the function I need is like this

public function UDTStream(pUDT as long) as string

Effectively I need to serialise the information inside a UDT. For simple types this is easy, but I need to check the types because some of the UDT's this function will encouter have UDTS within arrays of UDTS etc.

So does anyone out their know how to interrogate the structure of a UDT at runtime?

[dw85745]

Interesting Problem. This might help based on my search:

http://zone.ni.com/devzone/conceptd....2568F2007125C5

My thought here is to convert each structure element to a variant and then test it using the VB "Is" statements to determine its type.

David

[yrwyddfa]

I need to serialise the UDT so that I can make comparisons such as 'is equal too'

It's type is irrelevant, which is why I want to use a pointer; effectively it should be typefree.

I avoid variants like the plague, btw.

[dw85745]

Obviously NOT understanding the problem then.

I agree WHOLEHARDLY with variant comment.

Only suggested them as thought the problem was you were trying to detemine the various Data Types which make up an unknown UDT. Thought by assigning each UDT element to a variant type would then allow testing for UDT Data Type using the "Is" functions.

[CVMichael]

Maybe this helps: http://www.vbforums.com/showthread.php?t=355030

[yrwyddfa]

Yeah. I came across that earlier (I did search the forums before posting!!) but it will never work on any UDT of any complexity (ie contains strings, arrays, and so on)

I think I've found a way of doing it - so watch this space!

[penagate]

How do you propose to do your own type checking on an unmanaged language?

The furthest I can see it going is a shallow serialise, just the struct's immediate contents.

[yrwyddfa]

Watch this space . . . .

[randem]

yrwyddfa,

Basically you can't. Use an object that has all the elements defined in it and pass that.

[yrwyddfa]

yrwyddfa,

Basically you can't. Use an object that has all the elements defined in it and pass that.

Oh yes you can I'll post the code later today.

[yrwyddfa]

Here's for starters.

Option Explicit
 
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SysAllocString Lib "oleaut32" (ByVal pUnicodeString As Long) As String
Private Declare Sub ZeroMemory Lib "KERNEL32" Alias "RtlMoveMemory" (dest As Any, ByVal numBytes As Long)
 
Sub main()
    
    Dim Sr() As Byte
    Dim u As TEST_TYPE
    Dim u2 As TEST_TYPE
    Dim lp As Long
 
    With u
        .a = "a"
        .b = "b"
        .c = 12345
    End With
    
    Sr = Serialise(VarPtr(u), "TEST_TYPE", "c:\test.tlb")
    DeSerialise VarPtr(u2), "TEST_TYPE", "c:\test.tlb", Sr
    
End Sub
 
Public Function Serialise(pUDT As Long, UDTName As String, TLBFile As String) As Byte()
 
    On Error GoTo ERR_Serialise
    
    Dim TypeLib As TypeLibInfo
    Dim Record As RecordInfo
    Dim Mmbers As Members
    Dim Member As MemberInfo
    Dim Stream() As Byte
    Dim pMemPos As Long
    
    ReDim Stream(1024)
    
    '**************************
    '* Open type library . . .
    '**************************
    Set TypeLib = New TypeLibInfo
    TypeLib.ContainingFile = TLBFile
    
    '*********************************
    '* Get the UDT definition . . .
    '*********************************
    For Each Record In TypeLib.Records
        If Record.Name = UDTName Then
            Set Mmbers = Record.Members
            Exit For
        End If
    Next
    
    '****************************************
    '* Serialise Each and every member . . .
    '****************************************
    pMemPos = VarPtr(Stream(0))
    SerialiseUDT Mmbers, Stream, pUDT, pMemPos
    'ReDim Preserve Stream(pMemPos - VarPtr(Stream(0)))
    
    Serialise = Stream
    
    Exit Function
    
ERR_Serialise:
    Set TypeLib = Nothing
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function
 
Public Sub DeSerialise(pUDT As Long, UDTName As String, TLBFile, Stream() As Byte)
 
    On Error GoTo ERR_DeSerialise
    
    Dim TypeLib As TypeLibInfo
    Dim Record As RecordInfo
    Dim Mmbers As Members
    Dim Member As MemberInfo
    Dim pBufPos As Long
    Dim pMemPos As Long
    
    '**************************
    '* Open type library . . .
    '**************************
    Set TypeLib = New TypeLibInfo
    TypeLib.ContainingFile = TLBFile
    
    '*********************************
    '* Get the UDT definition . . .
    '*********************************
    For Each Record In TypeLib.Records
        If Record.Name = UDTName Then
            Set Mmbers = Record.Members
            Exit For
        End If
    Next
    
    '****************************************
    '* Serialise Each and every member . . .
    '****************************************
    DeSerialiseUDT Mmbers, VarPtr(Stream(0)), pUDT
    
    Exit Sub
    
ERR_DeSerialise:
    Set TypeLib = Nothing
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
 
Private Sub SerialiseUDT(Mmbers As Members, Buffer() As Byte, pUDT As Long, pStream As Long)
 
    On Error GoTo ERR_SerialiseUDT
    
    Dim Member As MemberInfo
    
    For Each Member In Mmbers
        Select Case Member.ReturnType.VarType
            Case vbString:
                SerialiseString pUDT, pStream
            Case vbInteger
                SerialiseData pUDT, pStream, 2, 2
        End Select
    Next
    
    Exit Sub
    
ERR_SerialiseUDT:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
 
Private Sub DeSerialiseUDT(Mmbers As Members, pStream As Long, pUDT As Long)
 
    On Error GoTo ERR_DeSerialise
 
    Dim Member As MemberInfo
    
    For Each Member In Mmbers
        Select Case Member.ReturnType.VarType
            Case vbString:
                DeSerialiseString pUDT, pStream
            Case vbInteger
                DeSerialiseData pUDT, pStream, 2, 2
        End Select
    Next
    
    Exit Sub
    
ERR_DeSerialise:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
 
 
Private Sub SerialiseData(pUDT As Long, pStream As Long, Alignment As Long, Size As Long)
 
    Dim lPadding As Long
    
    'Increment forward (if we have too) to make sure that we
    'only pick up the data and not the preceding padding bytes
    If Not (pUDT Mod Alignment = 0) Then
        lPadding = (Alignment - (pUDT Mod Alignment))
        pUDT = pUDT + lPadding
    End If
    
    'Serialise the data
    CopyMemory ByVal pStream, ByVal pUDT, Size
    
    'Increment pointers accordingly
    pUDT = pUDT + Size
    pStream = pStream + Size
    
End Sub
 
Private Sub DeSerialiseData(pUDT As Long, pStream As Long, Alignment As Long, Size As Long)
 
    Dim lPadding As Long
    
    'Pad data, if necessary
    If Not (pUDT Mod Alignment = 0) Then
        lPadding = (Alignment - (pUDT Mod Alignment))
        pUDT = pUDT + lPadding
    End If
    
    CopyMemory ByVal pUDT, ByVal pStream, Size
    
    pUDT = pUDT + Size
    pStream = pStream + Size
    
End Sub
 
 
Private Sub SerialiseString(pUDT As Long, pStream As Long)
    
    Dim Temp As String
    Dim pStr As Long
    Dim lPadding As Long
    
    'Ensure the alignment's good
    If Not (pUDT Mod 4 = 0) Then
        lPadding = (4 - (pUDT Mod 4))
        pUDT = pUDT + lPadding
    End If
    
    'deref pUDT, and get the actual string data
    CopyMemory pStr, ByVal pUDT, 4
    Temp = StrConv(SysAllocString(pStr), vbFromUnicode) & Chr(0)
    
    'Copy over the string data
    CopyMemory ByVal pStream, ByVal StrPtr(Temp), LenB(Temp)
    
    'Increment pointers
    pUDT = pUDT + 4
    pStream = pStream + LenB(Temp)
    
End Sub
 
Private Sub DeSerialiseString(pUDT As Long, pStream As Long)
 
    Dim Temp As String
    Dim lPadding As Long
 
    'Ensure the alignment's good
    If Not (pUDT Mod 4 = 0) Then
        lPadding = (4 - (pUDT Mod 4))
        pUDT = pUDT + lPadding
    End If
    
    'Get the string from the stream
    Temp = StrConv(SysAllocString(pStream), vbFromUnicode) & Chr(0)
    
    'Copy the BSTR descriptor to the UDT
    CopyMemory ByVal pUDT, ByVal VarPtr(Temp), 4
 
    'Increment pointers
    pStream = pStream + LenB(Temp)
    pUDT = pUDT + 4
    
    'Clear temp string descriptor to avoid VB's garbage collection
    CopyMemory ByVal VarPtr(Temp), 0&, 4
    
End Sub

You'll need to make reference to TLBINF32.DLL, and I can't upload a TLB file (invalid file type), so you'll need to point it to a typelib you've created (only using integer and variable strings at this point) I'm going to add the other types later today.

Let me know what you guys think.

[yrwyddfa]

To include ALL the basic types and the variable length string replace the relevant functions with this:

Private Sub SerialiseUDT(Mmbers As Members, Buffer() As Byte, pUDT As Long, pStream As Long)
 
    On Error GoTo ERR_SerialiseUDT
    
    Dim Member As MemberInfo
    
    For Each Member In Mmbers
        Select Case Member.ReturnType.VarType
            Case vbString:
                SerialiseString pUDT, pStream
            Case vbInteger
                SerialiseData pUDT, pStream, 2, 2
            Case vbLong
                SerialiseData pUDT, pStream, 4, 4
            Case vbBoolean
                SerialiseData pUDT, pStream, 2, 2
            Case vbSingle
                SerialiseData pUDT, pStream, 4, 4
            Case vbDouble
                SerialiseData pUDT, pStream, 4, 8
            Case vbCurrency
                SerialiseData pUDT, pStream, 4, 8
            Case vbDate
                SerialiseData pUDT, pStream, 4, 8
        End Select
    Next
    
    Exit Sub
    
ERR_SerialiseUDT:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
 
Private Sub DeSerialiseUDT(Mmbers As Members, pStream As Long, pUDT As Long)
 
    On Error GoTo ERR_DeSerialise
 
    Dim Member As MemberInfo
    
    For Each Member In Mmbers
        Select Case Member.ReturnType.VarType
            Case vbString:
                DeSerialiseString pUDT, pStream
            Case vbInteger
                DeSerialiseData pUDT, pStream, 2, 2
            Case vbLong
                DeSerialiseData pUDT, pStream, 4, 4
            Case vbBoolean
                DeSerialiseData pUDT, pStream, 2, 2
            Case vbSingle
                DeSerialiseData pUDT, pStream, 4, 4
            Case vbDouble
                DeSerialiseData pUDT, pStream, 4, 8
            Case vbCurrency
                DeSerialiseData pUDT, pStream, 4, 8
            Case vbDate
                DeSerialiseData pUDT, pStream, 4, 8
        End Select
    Next
    
    Exit Sub
    
ERR_DeSerialise:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub

[yrwyddfa]

I'll get to work on arrays, and arrays of UDT's now

[fingoldo]

I'll get to work on arrays, and arrays of UDT's now

Yrwyddfa, please, accept my deepest respect for your wonderful work on serializing of UDT's (that can be now turned cross-platform) in my favourite language :-)

Did you succeed in creating recursive version of 'Serialise' to parse UDT's inside UDTS?

Any luck with support of collections and arrays, variants, and nested stuff? :-)

Now that you showed the path to inspect type info on-line, this task seems to be straightforward, but may be you've already implemented these kinds of monster? :-)

Sincerely,
Anatoly