VB Forum / Win API / September 2003

The code below can be used to call any dll function. It can be used for a few other calls as well so is longer than it needs to be
just to call a dll. Paste it into a class and rename it CallPtr (or anything you prefer)

--
Michael Culley

Option Explicit

Public Enum mcCallTypeEnum
   mcCallStdCall
   mcCallDeclSpec
   mcCallCOMFunction
   mcCallCOMSub
End Enum

Private mlngParameters() As Long 'list of parameters
Private mlngAddress As Long 'address of function to call
Private mbytCode() As Byte 'buffer for assembly code
Private mCallType As mcCallTypeEnum 'type of function being called
Private mlngCP As Long 'used to keep track of latest byte added to code
Private mlngCodeAddress As Long 'address of first byte in mbytCode that stores the assembly code
Private mlngObjPtr As Long 'object pointer of object containing the function (zero for non COM calls)
Private mlngReturnVal As Long 'return values used for COM calls only
Private mlngHResult As Long
Private mlngModuleId As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal
Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Public Sub LoadDLL(DLLName As String)
   UnloadDLL
   mlngModuleId = LoadLibrary(DLLName)
   If mlngModuleId = 0 Then Err.Raise vbObjectError, "clsCallFunction.LoadDLL", "Load DLL failed"
End Sub

Public Sub UnloadDLL()
   If mlngModuleId <> 0 Then
       FreeLibrary mlngModuleId
       mlngModuleId = 0
   End If
End Sub

Public Property Let ObjectPointer(ByVal NewVal As Long)
   mlngObjPtr = NewVal
End Property
Public Property Get ObjectPointer() As Long
   ObjectPointer = mlngObjPtr
End Property

Public Property Let CallType(ByVal NewVal As mcCallTypeEnum)
   mCallType = NewVal
End Property
Public Property Get CallType() As mcCallTypeEnum
   CallType = mCallType
End Property

Public Property Get HResult() As Long
   HResult = mlngHResult
End Property

Public Property Let FunctionAddress(ByVal NewVal As Long)
   mlngAddress = NewVal
End Property
Public Property Get FunctionAddress() As Long
   FunctionAddress = mlngAddress
End Property

Public Sub ClearParameters()
   ReDim mlngParameters(0)
End Sub

Public Sub AddParameter(ByVal NewVal As Long)
   Dim lngX As Long
   lngX = UBound(mlngParameters) + 1
   ReDim Preserve mlngParameters(lngX)
   mlngParameters(lngX) = NewVal
End Sub

Public Function CallFunction() As Long
   If (mCallType = mcCallCOMFunction Or mCallType = mcCallCOMSub) And mlngObjPtr = 0 Then Err.Raise vbObjectError,
"clsCallFunction.CallFunction", "Cannot call Null COM object"
   Compile
   CallFunction = CallWindowProc(mlngCodeAddress, 0, 0, 0, 0)
   If mCallType = mcCallCOMFunction Then
       mlngHResult = CallFunction
       CallFunction = mlngReturnVal
   End If
End Function

Public Function CallDLLFunctionByName(FunctionName As String) As Long
   Dim mlngProcAddress As Long
   If mlngModuleId = 0 Then Err.Raise vbObjectError, "clsCallFunction.CallDLLFunctionByName", "No Dll loaded"
   mlngProcAddress = GetProcAddress(mlngModuleId, FunctionName)
   If mlngProcAddress = 0 Then Err.Raise vbObjectError, "clsCallFunction.CallDLLFunctionByName", "Function not found"
   mlngAddress = mlngProcAddress
   CallDLLFunctionByName = CallFunction
End Function

Private Sub Compile()
   Dim lngX As Long
   ReDim mbytCode(18 + 32 + 6 * UBound(mlngParameters))
   mlngCodeAddress = GetAlignedCodeStart(VarPtr(mbytCode(0)))
   mlngCP = mlngCodeAddress - VarPtr(mbytCode(0))
   For lngX = 0 To mlngCP - 1
       mbytCode(lngX) = &HCC
   Next
   'AddByteToCode &HCC 'int 03
   AddByteToCode &H58 'pop eax
   AddByteToCode &H59 'pop ecx
   AddByteToCode &H59 'pop ecx
   AddByteToCode &H59 'pop ecx
   AddByteToCode &H59 'pop ecx
   AddByteToCode &H50 'push eax
   If mCallType = mcCallCOMFunction Then
       AddByteToCode &H68 'push wwxxyyzz
       AddLongToCode VarPtr(mlngReturnVal)
   End If
   For lngX = UBound(mlngParameters) To 1 Step -1 'push parameters from right to left
       AddByteToCode &H68 'push wwxxyyzz
       AddLongToCode mlngParameters(lngX)
   Next
   If mCallType = mcCallCOMFunction Or mCallType = mcCallCOMSub Then
       AddByteToCode &H68 'push wwxxyyzz
       AddLongToCode mlngObjPtr
   End If
   AddCallToCode mlngAddress
   If mCallType = mcCallDeclSpec Then
       For lngX = 1 To UBound(mlngParameters)
           AddByteToCode &H59 'pop ecx
       Next
   End If
   AddByteToCode &HC3
   AddByteToCode &HCC

   'Assembler:
   '58                 pop     eax         'pop return address
   '59                 pop     ecx         'kill hwnd
   '59                 pop     ecx         'kill msg
   '59                 pop     ecx         'kill wParam
   '59                 pop     ecx         'kill lParam
   '50                 push    eax         'put back return address
   '68 zz yy xx ww     push    wwxxyyzz    'if COM call, push a pointer to a variable to be used as a return value

   '68 zz yy xx ww     push    wwxxyyzz    'once for each parameter, in reverse order

   '68 zz yy xx ww     push    wwxxyyzz    'if COM call, push Object Pointer to object being called
   'E8 zz yy xx ww     call    wwxxyyzz    'call function

   '59                 pop     ecx         'if DeclSpec call, parameters must be removed

   'C3                 ret
End Sub

Private Sub AddCallToCode(lngAddress As Long)
   AddByteToCode &HE8
   AddLongToCode lngAddress - VarPtr(mbytCode(mlngCP)) - 4
End Sub

Private Sub AddJumpToCode(lngAddress As Long)
   AddByteToCode &HE9
   AddLongToCode lngAddress - VarPtr(mbytCode(mlngCP)) - 4
End Sub

Private Sub AddLongToCode(lng As Long)
   Dim intX As Integer
   Dim byt(3) As Byte
   CopyMemory byt(0), lng, 4
   For intX = 0 To 3
       AddByteToCode byt(intX)
   Next
End Sub

Private Sub AddByteToCode(byt As Byte)
   mbytCode(mlngCP) = byt
   mlngCP = mlngCP + 1
End Sub

Private Function GetAlignedCodeStart(lngAddress As Long) As Long
   'align to 16 byte boundary for speed
   GetAlignedCodeStart = lngAddress + (15 - (lngAddress - 1) Mod 16)
   If (15 - (lngAddress - 1) Mod 16) = 0 Then GetAlignedCodeStart = GetAlignedCodeStart + 16
End Function

Private Sub Class_Initialize()
   ReDim mlngParameters(0)
   ReDim mbytCode(0)
End Sub

Private Sub Class_Terminate()
   UnloadDLL
End Sub