VBA Klasse: DyLib - Aufruf von Library-Funktionen über Funktionszeiger

Aus DBWiki
Wechseln zu: Navigation, Suche

Problem

Es sollen Funktionen einer externen Bibliothek genutzt werden können, deren Aufrufkonvention cdecl ist. Leider hat Microsoft die bereits in QuickBASIC vorhandene Möglichkeit der Declare-Anweisung mit dem zusätzlichem Schlüsselwort cdecl nicht in VBA übernommen, um API-Funktionen mit dieser Aufrufkonvention genauso bequem nutzen zu können, wie jene, deren Aufrufkonvention stdcall ist.

Lösung

Die etwas mager dokumentierte API-Funktion DispCallFunc stellt jedoch eine Möglichkeit zur Verfügung, auch Funktionen mit der Aufrufkonvention cdecl aus VBA nutzen zu können. Ein kleiner Wermutstropfen bei der Angelegenheit ist, dass DispCallFunc es erforderlich macht, die Funktionsargumente der aufzurufenden API-Funktion und deren Datentypen in einem Array zu übergeben, was zusätzliche Rechenzeit kostet. Deshalb dürfte die Klasse für stdcall-Aufrufe eher weniger attraktiv sein.

Der folgende Code muss in ein Klassenmodul kopiert werden. Ich habe es DyLib genannt. Wer ein Präfix vor Klassennamen bevorzugt, kann die Klasse natürlich auch in cDyLib oder clsDyLib umtaufen.

Option Explicit
 
' Aufrufkonventionen
Private Enum CALLINGCONVENTION_ENUM
   CC_FASTCALL
   CC_CDECL
   CC_PASCAL
   CC_MACPASCAL
   CC_STDCALL
   CC_FPFASTCALL
   CC_SYSCALL
   CC_MPWCDECL
   CC_MPWPASCAL
End Enum
 
#If VBA7 Then ' 64-Bit Architektur nicht getestet
 
Private Declare PtrSafe Function LoadLibraryA Lib "kernel32" ( _
   ByVal lpFileName As String) As LongPtr
 
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" ( _
   ByVal hModule As LongPtr) As Long
 
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" ( _
   ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
 
Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" ( _
   ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, _
   ByVal CC As Long, ByVal vtReturn As Integer, _
   ByVal cActuals As Long, ByVal prgvt As LongPtr, _
   ByVal prgpvarg As LongPtr, ByVal pvargResult As LongPtr) As Long
 
Private ModuleHandle As LongPtr
 
#Else ' VBA6
 
Private Declare Function LoadLibraryA Lib "kernel32" ( _
   ByVal lpFileName As String) As Long
 
Private Declare Function FreeLibrary Lib "kernel32" ( _
   ByVal hModule As Long) As Long
 
Private Declare Function GetProcAddress Lib "kernel32" ( _
   ByVal hModule As Long, ByVal lpProcName As String) As Long
 
Private Declare Function DispCallFunc Lib "oleaut32" ( _
   ByVal pvInstance As Long, ByVal oVft As Long, _
   ByVal CC As Long, ByVal vtReturn As Integer, _
   ByVal cActuals As Long, ByVal prgvt As Long, _
   ByVal prgpvarg As Long, ByVal pvargResult As Long) As Long
 
Private ModuleHandle As Long
 
#End If
 
' =============================================================================
 
' Prüft, ob die DLL geladen ist
Public Property Get IsLoaded() As Boolean
   IsLoaded = (Not ModuleHandle = 0)
End Property
 
' Lädt eine DLL
Public Sub Load(ByVal DyLibName As String)
   If IsLoaded Then Unload
   ModuleHandle = LoadLibraryA(DyLibName)
End Sub
 
' Entlädt eine DLL
Public Sub Unload()
   If Not IsLoaded Then Exit Sub
   Call FreeLibrary(ModuleHandle)
   ModuleHandle = 0
End Sub
 
' Methode aus der DLL aufrufen
Public Sub InvokeFunc(ByVal procName As String, _
                      ByRef result As Variant, _
                      ByVal resultType As VBA.VbVarType, _
                      Optional ByVal asCDecl As Boolean = True, _
                      Optional ByRef args As Variant)
 
   ' procName:   Name der Methode
   ' result:     Ergebnis des Methodenaufrufs
   ' resultType: Angabe des Datentyps, welche die Methode zurückgibt
   '             (VBA.vbEmpty für eine Sub verwenden)
   ' asCDecl:    Optional. Legt fest, ob die Aufrufkonvention cdecl oder stdcall
   '             verwendet wird. (Standard ist cdecl)
   ' args:       Optional. Einzelargument oder Argumentliste als Variant-Array
 
   Dim hRes As Long
   Dim varTypes() As Integer ' Array der Datentypen
   Dim varPtrs() As Long     ' Array von Argumentzeigern
   Dim numArgs As Long       ' Anzahl der Argumente (0-basiert)
   Dim i As Long             ' Zählvariable
 
   If Not IsLoaded Then _
      Err.Raise vbObjectError, "DyLib.InvokeFunc", "Kein Modul geladen."
 
   ' Gibt es genau ein (1) Argument?
   If Not VBA.IsMissing(args) And Not VBA.IsArray(args) Then
      ReDim varTypes(0) As Integer
      ReDim varPtrs(0) As Long
      varTypes(0) = VarType(args)
      varPtrs(0) = VarPtr(args)
   ElseIf VBA.IsArray(args) Then
      ' liegen mehrere Argumente vor
      numArgs = UBound(args)               ' Anzahl der Argumente ermitteln
      If (0 <= numArgs) Then               ' Ist das Array auch dimensiniert?
         ReDim varTypes(numArgs) As Integer
         ReDim varPtrs(numArgs) As Long
         For i = 0 To numArgs
            varTypes(i) = VarType(args(i)) ' Datentyp merken
            varPtrs(i) = VarPtr(args(i))   ' Pointer auf Argument merken
         Next
      End If
   End If
 
   ' API-Funktion aufrufen
   hRes = DispCallFunc(0, GetProcAddress(ModuleHandle, procName), _
                       IIf(asCDecl, CC_CDECL, CC_STDCALL), resultType, _
                       (UBound(varTypes) + 1), _
                       VarPtr(varTypes(0)), _
                       VarPtr(varPtrs(0)), VarPtr(result))
   If hRes Then Err.Raise hRes
End Sub
 
Private Sub Class_Terminate()
   ' aufräumen
   Unload
End Sub

Aufruf-Beispiel

' in einem separaten Modul
Sub TestMath()
   Dim dll As New DyLib
   Dim s As String
   Dim result As Variant
   Dim buffer As String
   Dim x1 As Double, x2 As Double, y As Double
 
   dll.Load "msvcrt"   'Visual C Runtime Library
   s = InputBox("Geben Sie eine reelle Zahl ein:", "DyLib-Test")
   If IsNumeric(s) Then
      x1 = CDbl(s)
      Call dll.InvokeFunc("atan", result, vbDouble, , CDbl(x1))
      y = result
      buffer = String$(64, vbNullChar)
      Call dll.InvokeFunc("swprintf_s", result, vbLong, True, _
                          Array(StrPtr(buffer), Len(buffer), _
                                StrPtr("Arcustangens von %f: %f"), x1, y))
      MsgBox Left$(buffer, result)
   Else
      Exit Sub
   End If
 
   s = InputBox("Geben Sie eine zweite reelle Zahl ein:", "DyLib-Test")
   If IsNumeric(s) Then
      x2 = CDbl(s)
      Call dll.InvokeFunc("atan2", result, vbDouble, , Array(CDbl(x1), CDbl(x2)))
      y = result
      buffer = String$(64, vbNullChar)
      Call dll.InvokeFunc("swprintf_s", result, vbLong, True, _
                          Array(StrPtr(buffer), Len(buffer), _
                                StrPtr("Arcustangens von %f / %f: %f"), x1, x2, y))
      MsgBox Left$(buffer, result)
   End If
End Sub