VB动态调用外部API函数的方法

这么久了都没放出过什么比较好的程序出来，让大家失望了。前段时间无聊搞了个类，今天拿出来和大家分享一下。 主要是实现在VB中动态调用API函数的类，才疏学浅，见笑了。 Visual Basic Code '********************************************************************************  '  'Name.......... APIClass  'File.......... APIClass.cls  'Version....... 1.0.0  'Dependencies.. kernel32.DLL  'Author........ Supermanking    'Date.......... Apr, 17nd 2008  'UpdateURL..... http://bbs.rljy.com/?m=vbAPIClass  '  'Copyright (c) 2008 by www.rljy.com  'Liuzhou city, China  '  '********************************************************************************  Option Explicit   '==============================================================================  '数据类型定义  '==============================================================================  Private Type VariableBuffer       VariableParameter (   )   As Byte   End Type   '==============================================================================  'API 函数声明  '==============================================================================  Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA"   ( ByVal lpLibFileName As String )   As Long   Private Declare Function GetProcAddress Lib "kernel32"   ( ByVal hModule As Long, ByVal lpProcName As String )   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 Function FreeLibrary Lib "kernel32"   ( ByVal hLibModule As Long )   As Long   Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"   ( lpDest As Any, lpSource As Any, ByVal cBytes As Long )     '==============================================================================  '成员定义  '==============================================================================  '类中的全局变量  Private m_opIndex As Long   Private m_OpCode (   )   As Byte   '********************************************************************************  '**  作    者 ：    人类(Supermanking)  '**  函 数 名 ：    ExecuteAPI  '**  输    入 ：    LIBPath(String)        -  刷新的目标窗口句柄，可为0  '**            ：    APIScript(String)      -  场景图像的宽度  '**  返    回 ：    (Long)                  -  返回零表示失败，非零表示成功  '**  功能描述 ：    动态执行类库里的API函数  '**  创建日期 ：    2008-04-17  '**  修 改 人 ：  '**  修改日期 ：  '**  版    本 ：    Version 1.0.0  '********************************************************************************  Public Function ExecuteAPI ( LibPath As String, APIScript As String )   As Long       Dim hProcAddress As Long, hModule As Long, X As Long, Y As Long       Dim RetLong As Long, FunctionName As String, FunctionParameter As String       Dim LongCount As Long, StringInfo As String, StrByteArray (   )   As VariableBuffer       Dim StringSize As Long, ByteArray (   )   As Byte, IsHaveParameter As Boolean       Dim ParameterArray (   )   As String, OutputArray (   )   As Long       StringSize   =   0       ReDim StrByteArray ( StringSize )       '识别函数名称      RetLong   =   InStr ( 1, APIScript, " ", vbTextCompare )         If RetLong   =   0 Then         '没有参数的函数              FunctionName   =   APIScript               IsHaveParameter   =   False       Else         '带参数的函数              FunctionName   =   Left ( APIScript, RetLong - 1 )                 IsHaveParameter   =   True                       '识别函数参数              FunctionParameter   =   Right ( APIScript, Len ( APIScript )   - RetLong )                 '分析函数参数              ParameterArray   =   Split ( FunctionParameter, "," )                 '初始化函数内存大小              ReDim OutputArray ( UBound ( ParameterArray )   )                 '格式化函数参数              For X   =   0 To UBound ( ParameterArray )                     If IsNumeric ( Trim ( ParameterArray ( X )   )   )     =   True Then                           LongCount   =   CLng ( Trim ( ParameterArray ( X )   )   )                             OutputArray ( X )     =   LongCount                   Else                           StringInfo   =   Mid ( Trim ( ParameterArray ( X )   ) , 2, Len ( ParameterArray ( X )   )   - 3 )                             If Len ( StringInfo )     =   0 Then                               OutputArray ( X )     =   CLng ( VarPtr ( Null )   )                             Else                               ReDim Preserve StrByteArray ( StringSize )                                 ByteArray   =   StrConv ( StringInfo, vbFromUnicode )                                 ReDim Preserve StrByteArray ( StringSize ) .VariableParameter ( UBound ( ByteArray )   + 1 )                                 CopyMemory StrByteArray ( StringSize ) .VariableParameter ( 0 ) , ByteArray ( 0 ) , UBound ( ByteArray )   + 1                               OutputArray ( X )     =   CLng ( VarPtr ( StrByteArray ( StringSize ) .VariableParameter ( 0 )   )   )                                 StringSize   =   StringSize + 1                           End If                   End If               Next X               ReDim m_OpCode ( 400 + 6 * UBound ( OutputArray )   )   '保留用来写m_OpCode       End If           '读取API库      hModule   =   LoadLibrary ( ByVal LibPath )         If hModule   =   0 Then               ExecuteAPI   =   0   'Library 读取失败               Exit Function       End If     '取得函数地址      hProcAddress   =   GetProcAddress ( hModule, ByVal FunctionName )         If hProcAddress   =   0 Then               ExecuteAPI   =   0   '函数读取失败               FreeLibrary hModule               Exit Function       End If             If IsHaveParameter   =   True Then         '带参数的情况在此执行              ExecuteAPI   =   CallWindowProc ( GetCodeStart ( hProcAddress, OutputArray ) , 0, 1, 2, 3 )         Else         '不带参数的情况在此执行              ExecuteAPI   =   CallWindowProc ( hProcAddress, 0, 1, 2, 3 )         End If           '释放库空间      FreeLibrary hModule   End Function   Private Function GetCodeStart ( ByVal lngProc As Long, arrParams (   )   As Long )   As Long           Dim lngIndex As Long, lngCodeStart As Long           lngCodeStart   =     ( VarPtr ( m_OpCode ( 0 )   )   Or &HF )   + 1           m_opIndex   =   lngCodeStart - VarPtr ( m_OpCode ( 0 )   )             For lngIndex   =   0 To m_opIndex - 1                   m_OpCode ( lngIndex )     =   &HCC           Next lngIndex           For lngIndex   =   UBound ( arrParams )   To 0 Step -1               AddByteToCode &H68               AddLongToCode arrParams ( lngIndex )             Next lngIndex           AddByteToCode &HE8           AddLongToCode lngProc - VarPtr ( m_OpCode ( m_opIndex )   )   - 4           AddByteToCode &HC2           AddByteToCode &H10           AddByteToCode &H0           GetCodeStart   =   lngCodeStart   End Function   Private Sub AddLongToCode ( lData As Long )             CopyMemory m_OpCode ( m_opIndex ) , lData, 4           m_opIndex   =   m_opIndex + 4   End Sub   Private Sub AddIntToCode ( iData As Integer )             CopyMemory m_OpCode ( m_opIndex ) , iData, 2           m_opIndex   =   m_opIndex + 2   End Sub   Private Sub AddByteToCode ( bData As Byte )             m_OpCode ( m_opIndex )     =   bData           m_opIndex   =   m_opIndex + 1   End Sub 使用方法也很简单，我举个例子： Visual Basic Code Private Sub Command1_Click (   )           Dim API As New APIClass         Dim APIScript As String      '最简单的调用API函数        APIScript   =   "MessageBoxA 0, ""这是动态调用API函数显示的MSGBOX内容，下面将要在作面画一笔。"", ""API信息提示"", 0"         API.ExecuteAPI "C:/WINDOWS/system32/user32.dll", APIScript                '=============在作面画画============        Dim DesktophWnd As Long, DesktophDC As Long      '取得桌面窗口句柄        DesktophWnd   =   API.ExecuteAPI ( "C:/WINDOWS/system32/user32.dll", "GetDesktopWindow" )        '取得桌面窗口设备句柄        DesktophDC   =   API.ExecuteAPI ( "C:/WINDOWS/system32/user32.dll", "GetWindowDC " & DesktophWnd )        '在作面设备上画一条线        API.ExecuteAPI "C:/WINDOWS/system32/gdi32.dll", "LineTo " & DesktophDC & "," & Screen.Width / 15 & "," & Screen.Height / 15   End Sub