Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0797: IEnumVariant per lightweight Object Implementieren

VB 5/6-Tipp 0797: IEnumVariant per lightweight Object Implementieren

 von OlimilO

Schwierigkeitsgrad:

Verwendete API-Aufrufe: VarPtr (ArrPtr), RtlMoveMemory, RtlZeroMemory

Download: Download des Beispielprojektes [6,91 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: Schaltfläche "CmdWalkListForI"
' Steuerelement: Schaltfläche "CmdWalkListForEach"
' Steuerelement: Schaltfläche "CmdWalkArrayAsDoubleForI"
' Steuerelement: Schaltfläche "CmdWalkArrayAsDoubleForEach"
' Steuerelement: Schaltfläche "CmdWalkRefArrayForI"
' Steuerelement: Schaltfläche "CmdWalkRefArrayForEach"
' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label5"
' Steuerelement: Beschriftungsfeld "Label6"
Option Explicit
'
' Hier wird gezeigt wie man die IEnumVariant-Schnittstelle über ein Lightweight Objekt
' implementiert, um in einer eigenen Listenklasse das VB-Sprachmerkmal For-Each zu
' unterstützen. Die Listenklasse List dient hier nur als Beispiel und stellt einen
' Prototpy einer generischen Liste dar.
'
Private myList As List
Private Const m_u As Long = 999999
Private myDblArr(0 To m_u) As Double

Private Sub Form_Load()
    ' Spezialisierung der Listenklasse zur Designzeit als Liste von Doubles
    Set myList = New_List(vbDouble)
    Dim i As Long
    Dim d As Double
    For i = 0 To m_u
        d = Rnd * (i + 1)
        Call myList.Add(d)
        myDblArr(i) = d
    Next
    MsgBox "Count: " & myList.Count & " Capacity: " & myList.Capacity
End Sub

Private Sub CmdWalkListForI_Click()
    'die Liste mit For i durchwandern
    Dim dt As Double: dt = Timer
    Dim d As Double
    Dim i As Long
    For i = 0 To myList.Count - 1
        d = myList(i)
    Next
    dt = Timer - dt
    Label1 = Format(dt, "0.000")
End Sub
Private Sub CmdWalkListForEach_Click()
    'die Liste mit For Each durchwandern
    Dim dt As Double: dt = Timer
    Dim d As Double
    Dim v, i As Long
    For Each v In myList
        d = v
    Next
    dt = Timer - dt
    Label2 = Format(dt, "0.000")
End Sub

Private Sub CmdWalkArrayAsDoubleForI_Click()
    'ein Array() As Double mit For I durchwandern
    Dim dt As Double: dt = Timer
    Dim d As Double
    Dim i As Long
    For i = LBound(myDblArr) To UBound(myDblArr)
        d = myDblArr(i)
    Next
    dt = Timer - dt
    Label3 = Format(dt, "0.000")
End Sub
Private Sub CmdWalkArrayAsDoubleForEach_Click()
    'ein Array() As Double mit For Each durchwandern
    Dim dt As Double: dt = Timer
    Dim d As Double
    Dim v
    For Each v In myDblArr
        d = v
    Next
    dt = Timer - dt
    Label4 = Format(dt, "0.000")
End Sub

Private Sub CmdWalkRefArrayForI_Click()
    'ein referenziertes Array() As Double mit For I durchwandern
    Dim dt As Double: dt = Timer
    Dim dArr() As Double: SAPtr(ArrPtr(dArr)) = myList.SAPtr
    Dim d As Double
    Dim i As Long
    For i = LBound(dArr) To UBound(dArr)
        d = dArr(i)
    Next
    dt = Timer - dt
    Label5 = Format(dt, "0.000")
    ZeroSAPtr ArrPtr(dArr)
End Sub
Private Sub CmdWalkRefArrayForEach_Click()
    'ein referenziertes Array() As Double mit For Each durchwandern
    Dim dt As Double: dt = Timer
    Dim dArr() As Double: SAPtr(ArrPtr(dArr)) = myList.SAPtr
    Dim d As Double
    Dim v
    For Each v In dArr
        d = v
    Next
    dt = Timer - dt
    Label6 = Format(dt, "0.000")
    ZeroSAPtr ArrPtr(dArr)
End Sub


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'---- Anfang Modul "MEnumVariant" alias MEnumVariant.bas ----
Option Explicit
'Ein Lightweight Object für ein Enumerator-Objekt das IEnumVariant implementiert
'zur Info GUID von IEnumVariant: 00020404-0000-0000-C000-000000000046
Private Type VBGuid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data5(0 To 7) As Byte
End Type

'Eine VTable enthält Zeiger auf die Funktionen einer Klasse
Private Type TEnumVariantVTable
    VTable(0 To 6) As Long
End Type

'Unterscheidung in Objekte und einfache Datentypen durch zwei verschiedene Next-Funktionen
Private EnumObjVTable As TEnumVariantVTable
Private m_pVTableObj As Long

'man könnte auch für jeden einfachen Datentyp ein eigenes EnumVariant-Objekt erstellen mit
'jeweils unterschiedlichen Next-Funktionen
Private EnumVarVTable As TEnumVariantVTable
Private m_pVTableVar As Long

'
Public Type TEnumVariant
    pVTable As Long      'erstes Element in einem Objekt ist immer ein Zeigr auf die VTable
    refCnt  As Long      'der Referenzzähler
    Array   As Variant   'der Variant enthält einen Zeiger auf ein Array beliebigen Typs
    Count   As Long      'die Anzahl der abzulaufenden Elemente im Array
    Index   As Long      'der Indexzähler, Index auf das nächste Element
End Type
Private Const S_OK = &H0&
Private Const S_FALSE = &H1&

Public Sub InitEnumVariantVTable()
    'Initialisierung der Funktionszeiger der IEnumVariant Lightweight Klasse
    'soll im Projekt nur einmal aufgerufen werden, z.B. von Sub Main
    'In VB ist eine Sub eigentlich auch eine Funktion, da immer ein HResult
    'zurückgegeben wird.
    With EnumVarVTable
        .VTable(0) = FncPtr(AddressOf FncQueryInterface)
        .VTable(1) = FncPtr(AddressOf SubAddRef)
        .VTable(2) = FncPtr(AddressOf SubRelease)
        .VTable(4) = FncPtr(AddressOf SubSkip)
        .VTable(5) = FncPtr(AddressOf SubReset)
        .VTable(6) = FncPtr(AddressOf FncClone)
    End With
    EnumObjVTable = EnumVarVTable
    EnumObjVTable.VTable(3) = FncPtr(AddressOf FncNextObj) 'für Objekttypen
    EnumVarVTable.VTable(3) = FncPtr(AddressOf FncNextVar) 'für einfache Datentypen
    '...
    m_pVTableVar = VarPtr(EnumVarVTable)
    m_pVTableObj = VarPtr(EnumObjVTable)
    
End Sub
Private Function FncPtr(ByVal pFnc As Long) As Long
    FncPtr = pFnc
End Function

Public Function New_Enum(Me_ As TEnumVariant, _
                         Arr As Variant, _
                         ByVal vt As VbVarType, _
                         ByVal Count As Long) As IUnknown
    With Me_
        'man könnte auch für jeden Datentyp eine eigene Next-Prozedur verwenden
        .pVTable = IIf(vt = vbObject, m_pVTableObj, m_pVTableVar)
        
        'Den Zeiger auf das Array komplett aus dem Variant in den Variant kopieren
        RtlMoveMemory .Array, Arr, 16
        .Count = Count
        .Index = 0
        .refCnt = 2
    End With
    
    'das Objekt zum Leben erwecken
    RtlMoveMemory New_Enum, VarPtr(Me_), 4
End Function

Private Function FncQueryInterface(Me_ As TEnumVariant, riid As VBGuid, pvObj As Long) As Long
    
    ' Hier frägt VB das Objekt, ob es sich "wirklich" um ein IEnumVariant-Objekt handelt.
    ' Man braucht diese Abfrage eigentlich nicht, da wir ja wissen welches Objekt es ist.
    ' Es soll hier nur exemplarisch gezeigt werden wie eine solche Abfrage aussehen kann.
    ' Es muss aber in jedem Fall in pvObj ein Zeiger auf das Objekt zurückgegeben werden.
    
    With riid
        If .Data1 = &H20404 And _
           .Data2 = 0 And _
           .Data3 = 0 And _
           .Data5(0) = &HC0 And _
           .Data5(7) = &H46 Then
            pvObj = VarPtr(Me_)
        End If
    End With
    
    ' kann man auch weglassen da S_OK sowieso nur 0 ist
    FncQueryInterface = S_OK ' ja wir haben das Interface

End Function

Private Function SubAddRef(Me_ As TEnumVariant) As Long
    ' hier wird eine Referenz hinzugefügt
    With Me_
        .refCnt = .refCnt + 1
    End With
End Function

Private Function SubRelease(Me_ As TEnumVariant) As Long
    ' hier wird eine Referenz abgezogen
    ' wird diese Funktion wiederholt aufgerufen, solange bis refCounter = 0
    ' dann den Zeiger auf das Array im Variant Array wieder löschen
    With Me_
        .refCnt = .refCnt - 1
        If .refCnt = 0 Then RtlZeroMemory .Array, 16
    End With
End Function

Private Function FncNextObj(Me_ As TEnumVariant, _
                            ByVal celt As Long, _
                            rgvar, _
                            pceltFetched As Long) As Long
    ' Dies ist die wichtigste Funktion von IEnumVariant.
    ' Über Count wird entschieden wann der Vorgang abgebrochen wird.
    With Me_
        If .Index = .Count Then FncNextObj = S_FALSE: Exit Function
        Set rgvar = .Array(.Index)
        .Index = .Index + 1
    End With
End Function

Private Function FncNextVar(Me_ As TEnumVariant, _
                            ByVal celt As Long, rgvar, pceltFetched As Long) As Long
    'Dies ist die wichtigste Funktion von IEnumVariant.
    ' Über Count wird entschieden wann der Vorgang abgebrochen wird.
    With Me_
        If .Index = .Count Then FncNextVar = S_FALSE: Exit Function
        rgvar = .Array(.Index)
        .Index = .Index + 1
    End With
End Function

Private Function SubSkip(Me_ As TEnumVariant, ByVal celt As Long) As Long
    'hier nur Dummy-Funktion, wird nicht verwendet
End Function

Private Function SubReset(Me_ As TEnumVariant) As Long
    'hier nur Dummy-Funktion, wird nicht verwendet
End Function

Private Function FncClone(Me_ As TEnumVariant, retOther As TEnumVariant) As Long
    'hier nur Dummy-Funktion, wird nicht verwendet
End Function
'----- Ende Modul "MEnumVariant" alias MEnumVariant.bas -----
'----------- Anfang Modul "MMain" alias MMain.bas -----------
Option Explicit

Public Sub Main()
    MEnumVariant.InitEnumVariantVTable
    Form1.Show
End Sub

Public Function New_List(Of_Type As VbVarType) As List
    Set New_List = New List
    Call New_List.New_(Of_Type)
End Function
'------------ Ende Modul "MMain" alias MMain.bas ------------
'---------- Anfang Modul "MArray" alias MArray.bas ----------
Option Explicit

Public Declare Sub RtlMoveMemory Lib "kernel32" ( _
    ByRef Dst As Any, ByRef Src As Any, ByVal BytLength As Long)
    
Public Declare Sub RtlZeroMemory Lib "kernel32" ( _
    ByRef Dst As Any, ByVal BytLength As Long)
    
'die Funktion ArrPtr geht bei allen Arrays außer bei String-Arrays
Public Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" ( _
    ByRef Arr() As Any) As Long

'deswegen hier eine Hilfsfunktion für StringArrays
Public Function StrArrPtr(ByRef strArr As Variant) As Long
    Call RtlMoveMemory(StrArrPtr, ByVal VarPtr(strArr) + 8, 4)
End Function

'jetzt kann das Property SAPtr für Alle Arrays verwendet werden,
'um den Zeiger auf den Safe-Array-Descriptor eines Arrays einem
'anderen Array zuzuweisen.
Public Property Get VSAPtr(VArr As Variant) As Long
    Call RtlMoveMemory(VSAPtr, ByVal VarPtr(VArr) + 8, 4)
End Property
Public Property Let VSAPtr(VArr As Variant, ByVal RHS As Long)
    Call RtlMoveMemory(ByVal VarPtr(VArr) + 8, ByVal RHS, 4)
End Property

Public Property Get SAPtr(ByVal pArr As Long) As Long
    Call RtlMoveMemory(SAPtr, ByVal pArr, 4)
End Property
Public Property Let SAPtr(ByVal pArr As Long, ByVal RHS As Long)
    Call RtlMoveMemory(ByVal pArr, RHS, 4)
End Property

Public Sub ZeroSAPtr(ByVal pArr As Long)
    Call RtlZeroMemory(ByVal pArr, 4)
End Sub
'----------- Ende Modul "MArray" alias MArray.bas -----------
'----------- Anfang Klasse "List" alias List.cls  -----------
Option Explicit
'Public Class List
'Prototyp einer generischen Liste, der Typ des Arrays wird zur Designzeit festgelegt
Private m_Array
Private m_Count As Long
Private m_vType As VbVarType
Private m_EnumV As TEnumVariant

Friend Sub New_(Of_Type As VbVarType)
    m_vType = Of_Type
    Clear
End Sub

Public Sub Add(Item As Variant)
    Me.Capacity = m_Count
    If m_vType = vbObject Then
        Set m_Array(m_Count) = Item
    Else
        m_Array(m_Count) = Item
    End If
    m_Count = m_Count + 1
End Sub

Public Property Get Capacity() As Long
    Capacity = UBound(m_Array) + 1
End Property

Public Property Let Capacity(Value As Long)
    Dim cap As Long: cap = UBound(m_Array) + 1
    If cap <= Value Then
        cap = cap * 2
        If cap < Value Then cap = Value
        ReDim Preserve m_Array(0 To cap - 1)
    End If
End Property
Public Property Get SAPtr() As Long
    SAPtr = VSAPtr(m_Array)
End Property
Public Property Get DataPtr() As Long
    DataPtr = VarPtr(m_Array(0))
End Property
Public Sub Clear()
    Dim u As Long
    u = 3
    Select Case m_vType
    Case vbInteger  '2
        ReDim m_Array(0 To u) As Integer
    Case vbLong     '3
        ReDim m_Array(0 To u) As Long
    Case vbSingle   '4
        ReDim m_Array(0 To u) As Single
    Case vbDouble   '5
        ReDim m_Array(0 To u) As Double
    Case vbCurrency '6
        ReDim m_Array(0 To u) As Currency
    Case vbDate     '7
        ReDim m_Array(0 To u) As Date
    Case vbString   '8
        ReDim m_Array(0 To u) As String
    Case vbObject   '9
        ReDim m_Array(0 To u) As Object
    Case vbBoolean  '11
        ReDim m_Array(0 To u) As Boolean
    Case vbVariant, vbDecimal '12, 14
        ReDim m_Array(0 To u) As Variant
    Case vbByte    '17
        ReDim m_Array(0 To u) As Byte
    End Select
    m_Count = 0
End Sub

Public Property Get Count()
    Count = m_Count
End Property

Public Function GetEnum() As IUnknown
    ' Prozedur-Id = -4
    Set GetEnum = New_Enum(m_EnumV, m_Array, m_vType, m_Count)
End Function

Public Property Get Item(Index As Long) As Variant
    'Prozedur-Id = (Voreinstellung) 'Default
    If m_vType = vbObject Then
        Set Item = m_Array(Index)
    Else
        Item = m_Array(Index)
    End If
End Property

Public Property Let Item(Index As Long, Value As Variant)
    m_Array(Index) = Value
End Property

Public Property Set Item(Index As Long, Value As Variant)
    Set m_Array(Index) = Value
End Property

'------------ Ende Klasse "List" alias List.cls  ------------
'-------------- Ende Projektdatei Projekt1.vbp --------------