VB动态调用API函数模块

'//女孩不哭(QQ:191035066)@2011-12-23 22:03:37
Option  Explicit

Private  Type VariableBuffer
   VariableParameter()       As Byte
End  Type

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

Public Function  ShellAPI( ByVal  LibPath$, APIParam$)  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 , APIParam,  " " , vbTextCompare)
    If  RetLong =  0  Then
       FunctionName = APIParam
      IsHaveParameter =  False
   Else
       FunctionName = Left(APIParam, RetLong -  1 )
      IsHaveParameter =  True
       FunctionParameter = Right(APIParam, Len(APIParam) - 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))
    End If
    
    hModule = LoadLibrary( ByVal  LibPath)
    If  hModule =  0  Then
          ShellAPI =  0
          MsgBox  "LoadLibrary("""  & LibPath &  """) 函数调用失败!" , vbCritical
          Exit Function
   End If

    hProcAddress = GetProcAddress(hModule,  ByVal  FunctionName)
    If  hProcAddress =  0  Then
       ShellAPI =  0
       MsgBox  "GetProcAddress("""  & FunctionName &  """) 函数调用失败!" , vbCritical
      FreeLibrary hModule
       Exit Function
   End If
    
   If  IsHaveParameter =  True Then
       ShellAPI = CallWindowProc(GetCodeStart(hProcAddress, OutputArray),  0 ,  1 ,  2 ,  3 )
    Else
       ShellAPI = 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