这么久了都没放出过什么比较好的程序出来，让大家失望了。前段时间无聊搞了个类，今天拿出来和大家分享一下。
主要是实现在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 |
|
