Using Dynamic Creation of automated interfaces for VB function pointer calling

Sender: roachcock (chen3feng), email area: microsofttrd
Question: My VB function pointer call
Mailing site: BBS shuimu Tsinghua station (Fri Jan 3 14:54:25 2003)

This article is first published in the shuimu Tsinghua BBS microsofttrd version. Please keep the relevant information

Chen3feng (RoachCock@smth.org)
Email: chen3feng@163.com, chen3fengx@hotmail.com


A few days ago, I saw a VB function pointer call by Matthew Curland at the csdn documentation center. It uses dynamic creation of custom interface pointers.
And then return a method. However, although this method is highly efficient, each function needs to create a custom interface.
Type, you have to use the IDL Language, it is not convenient, I tried a solution yesterday, that is, dynamic creation from
Interactive interface pointer. Although the efficiency is low, it is flexible enough to make up for this weakness.

I only use two APIs
For this reason, I used two Ole APIs:

Private declare function createdisptypeinfo lib "oleaut32" (byref pidata _
Interfacedata, byval lcid as long, byref pptinfo as iunknown) as long

Private declare function createstddispatch lib "oleaut32" (byval punkouter _
As iunknown, byref pvthis as delegator, byval ptinfo as iunknown, byref _
Ppunkstddisp as iunknown) as long

The previous function creates a type information based on the specified description data. The latter creates a type information based on the specified interface and type information.
Create an idispatch pointer // The object type of VB corresponds to the idispatch smart pointer of VC

To create type information, you must enter a data structure. Therefore, you must introduce constants, types, and functions from oleaut. h.
Statement. For more information about the two APIs, see msdn

Implementation Method
First, we need to simulate the class structure in C ++. We need a custom structure to represent the object,
'Proxy object
Private type delegator
Pvtbl as long 'virtual function table pointer
Pfunc as long 'a data member, which is the pointer to the function to be called
End type

'Virtual function table
Private type vtable
Pthunk as long 'points to a thunk function written in x86 machine language. Of course, I first use
End type 'write. The machine code is copied

The thunk assembly code is as follows:
'The machine code of thunk, plus NOP is to consolidate, each valid instruction is filled with a dual word, relatively clear
M_thunk (0) = & hsf-4c8b 'mov ECx, [esp + 4] Get This pointer
M_thunk (1) = & h9004418b 'mov eax, [ECx + 4] NOP get m_pfunc
M_thunk (2) = & h90240c8b 'mov ECx, [esp] NOP get return address
M_thunk (3) = & hsf-4c89 'mov [esp + 4], ECx save return address
M_thunk (4) = & h9004c483 'add ESP, 4 NOP re-adjust Stack
M_thunk (5) = & h9090e0ff 'jmp eax jump to m_pfunc

The name of the created method is invoke and dispid is 0. That is to say, the method can be called directly without the Member

Sample Code
Private sub form_load ()
Dim P as functionptr
Set P = new functionptr
Dim D as object
Set d = P. Create (addressof test, vbempty, vbstring)
'Test is a standard module function.
D. invoke "hehe"
D "hehe" 'can omit invoke

'Call Win32 API messageboxw
Dim hmoduser32
Dim pmessageboxw as long
Hmoduser32 = getmodulehandle ("USER32 ")
Pmessageboxw = getprocaddress (hmoduser32, "messageboxw ")
Dim MBW as new functionptr
Dim messageboxw as object
Set messageboxw = MBW. Create (pmessageboxw, vt_i4, vt_i4, vt_bstr ,_
Vt_bstr, vt_i4)
Messageboxw 0, "hehe, form messageboxw", "", 0' can omit invoke
End sub
'Compile the above Code and introduce the type library operation library.

It must be noted that, because oleaut32 only supports the conversion of automatic compatible types, only the automatic compatible types can be used.

In addition, because VB classes do not support aggregation, the external iunknown pointer of the first parameter of createstddispatch
This means that the functionptr object must be automated in the create method.
It is a pity that the interface pointer is valid for a lifetime.

Although VC is widely used during debugging, no additional dynamic Connection Library is required after debugging.
You only need to add the functionptr class module to the project, create an object of the functionptr type, and call create
You can get the automation objects that can be used back and forth.
The first parameter of create is the function pointer, and the second parameter is the function return value type, followed by an indefinite number of parameters.
Is the type of function parameters. It is easy to use.


Source code, including the complete test project
'Functionptr. cls' function pointer class definition
Version 1.0 class
Begin
Multiuse =-1 'true'
Persistable = 0 'notpersistable
Databindingbehavior = 0 'vbnone
Performancebehavior = 0 'vbnone
Mtstransactionmode = 0 'notanmtsobject
End
Attribute vb_name = "functionptr"
Attribute vb_globalnamespace = false
Attribute vb_creatable = true
Attribute vb_predeclaredid = false
Attribute vb_exposed = false
Option explicit

Private const dispatch_method = & H1
Private const locale_system_default = & h800
Private const dispid_value = 0

Private Enum callconv
Cc_fastcall = 0
Cc_cdecl = 1
Cc_mscpascal = cc_cdecl + 1
Cc_pascal = cc_mscpascal
Cc_macpascal = cc_pascal + 1
Cc_stdcall = cc_macpascal + 1
Cc_fpfastcall = cc_stdcall + 1
Cc_syscall = cc_fpfastcall + 1
Cc_mpwcdecl = cc_syscall + 1
Cc_mpwpascal = cc_mpwcdecl + 1
Cc_max = cc_mpwpascal + 1
End Enum

Private type paramdata
Szname as string
VT as varianttypeconstants
End type

Private type methoddata
Szname as string
Ppdata as long '/* pointer to an array of paramdatas */
Dispid as long '/* method ID */
Imeth as long '/* method Index */
Cc as callconv '/* calling convention */
Cargs as long '/* count of arguments */
Wflags as integer '/* same wflags as on idispatch: invoke ()*/
Vtreturn as integer
End type

Private type interfacedata
Pmethdata as long '/* pointer to an array of methoddatas */
Cmembers as long
End type

Private declare function createdisptypeinfo lib "oleaut32" (byref pidata as interfacedata, byval lcid as long, byref pptinfo as iunknown) as long
Private declare function createstddispatch lib "oleaut32" (byval punkouter as iunknown, byref pvthis as delegator, byval ptinfo as iunknown, byref ppunkstddisp as iunknown) as long

Private type vtable
Pthunk as long
End type

Private type delegator
Pvtbl as long
Pfunc as long
End type

Private m_thunk (5) as long

Private m_vtable as vtable
Private m_delegator as delegator
Private m_interfacedata as interfacedata
Private m_methoddata as methoddata
Private m_paramdata () as paramdata
Private m_functionptr as object

Public Function create (byval pfunc as long, byval rettype as varianttypeconstants, paramarray paramtypes () as variant) as object

If typename (m_functionptr) <> "nothing" then
Set create = m_functionptr
Exit Function
End if

Dim I as long
Dim P as long
Dim cparam as long
Cparam = ubound (paramtypes) + 1

Redim m_paramdata (cparam)

If cparam then
For I = 0 to cparam-1
M_paramdata (I). Vt = paramtypes (I)
M_paramdata (I). szname = ""
Next
End if
M_methoddata.szname = "INVOKE"
M_methoddata.ppdata = varptr (m_paramdata (0 ))
M_methoddata.dispid = dispid_value
M_methoddata.imeth = 0
M_methoddata.cc = cc_stdcall
M_methoddata.cargs = cparam
M_methoddata.wflags = dispatch_method
M_methoddata.vtreturn = rettype

M_interfacedata.pmethdata = varptr (m_methoddata)
M_interfacedata.cmembers = 1

Dim Ti as iunknown
Dim result as iunknown
Set result = nothing
I = createdisptypeinfo (m_interfacedata, locale_system_default, Ti)
If I = 0 then
M_vtable.pthunk = varptr (m_thunk (0 ))

M_delegator.pvtbl = varptr (m_vtable)
M_delegator.pfunc = pfunc
P = varptr (m_interfacedata)
P = varptr (m_delegator)
I = createstddispatch (nothing, m_delegator, Ti, result)
If I = 0 then
Set m_functionptr = Result
Set create = m_functionptr
End if
End if
End Function

Private sub class_initialize ()
'Thunk machine code, plus NOP is for clarity
M_thunk (0) = & hsf-4c8b 'mov ECx, [esp + 4] Get This pointer
M_thunk (1) = & h9004418b 'mov eax, [ECx + 4] NOP get m_pfunc
M_thunk (2) = & h90240c8b 'mov ECx, [esp] NOP get return address
M_thunk (3) = & hsf-4c89 'mov [esp + 4], ECx save return address
M_thunk (4) = & h9004c483 'add ESP, 4 NOP re-adjust Stack
M_thunk (5) = & h9090e0ff 'jmp eax jump to m_pfunc
End sub

'Helper. cls' is not actually a helper, but its original name. It contains the function for testing.
Attribute vb_name = "helper"
Option explicit

Sub test1 (byref this as long)
Msgbox "test1", vbokonly, "hehe"
End sub

Sub test (byval s as string)
Msgbox S, vbokonly, "hehe"
End sub


'Test the program
Option explicit

Private declare function getmodulehandle lib "Kernel32" alias "getmodulehandlea" (byval lpmodulename as string) as long
Private declare function getprocaddress lib "Kernel32" (byval hmodule as long, byval lpprocname as string) as long

Private sub form_load ()
Dim P as functionptr
Set P = new functionptr

Dim D as object
Set d = P. Create (addressof test, vbempty, vbstring)

D. Invoke ("hehe ")

Dim hmoduser32
Dim pmessageboxw as long

Hmoduser32 = getmodulehandle ("USER32 ")
Pmessageboxw = getprocaddress (hmoduser32, "messageboxw ")
Dim MBW as new functionptr
Dim messageboxw as object
Set messageboxw = MBW. Create (pmessageboxw, vblong, vblong, vbstring, vbstring, vblong)
'Messageboxa 0, "hehe, form messageboxa", "", 0
Messageboxw. Invoke 0, "hehe, form messageboxw", "", 0
End sub


'Project File
Type = exe
Reference = */G {00020430-0000-0000-c000-000000000046} #2.0 #0 # C:/Windows/system/
Stdole2.tlb # OLE Automation
Form = form1.frm
Module = helper; helper. Bas
Class = functionptr; functionptr. CLs
Iconform = "form1"
Startup = "form1"
Helpfile = ""
Title = "Project 1"
Exename32 = "project 1.exe"
Command32 = ""
Name = "Project 1"
Helpcontextid = "0"
Compatiblemode = "0"
Majorver = 1
Minorver = 0
Revisionver = 0
Autoincrementver = 0
Serversupportfiles = 0
Compilationtype = 0
Optimizationtype = 2
Favorpentiumpro (TM) = 0
Codeviewdebuginfo =-1
Noaliasing = 0
Boundscheck = 0
Overflowcheck = 0
Flpointcheck = 0

Fdivcheck = 0
Unroundedfp = 0
Startmode = 0
Unattended = 0
Retained = 0
Threadperobject = 0
Maxnumberofthreads = 1