VB动态调用外部API函数的方法
这么久了都没放出过什么比较好的程序出来，让大家失望了。前段时间无聊搞了个类，今天拿出来和大家分享一下
主要是实现在VB中动态调用API函数的类，才疏学浅，见笑了。
'******************************************************************************** ' 'Name.......... APIClass 'File.......... APIClass.cls 'Version....... 1.0.0 'Dependencies.. kernel32.DLL 'Author........ Zhou Wen Xing<humanhome@126.com> '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) = Next lngIndex For lngIndex = UBound(arrParams) To 0 Step -1 AddByteToCode AddLongToCode arrParams(lngIndex) Next lngIndex AddByteToCode AddLongToCode lngProc - VarPtr(m_OpCode(m_opIndex)) - 4 AddByteToCode AddByteToCode AddByteToCode 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
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
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
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
[解决办法]
认真学习！
[解决办法]
认真学习！给顶。
[解决办法]
谢谢lz,收藏
[解决办法]
想原样就得贴图片，论坛铁定会有某些字符限制。
[解决办法]
vb.net 写的DLL 能不能 在VB上面动态加载呢?
[解决办法]
受教了……
[解决办法]
急求：本人欲在傲游(Maxthon)浏览器的工具栏上安装一个自定义按钮，该按钮的功能是：当我按下该按钮时，启动d:\euro\hot.exe程序（该程序功能是：在当前网页中，搜索关键字，并将搜索结果及相关字段内容存入名为Asia2008.dbf数据库中,关闭当前网页）。请各位大侠指点做法，如有可能给出相关源程序，小生万分感谢！(Euro2000@126.com)
[解决办法]
认真学习
[解决办法]
lz真是强人,我要认真学习一下
[解决办法]
谢谢lz,收藏
[解决办法]
学习学习
[解决办法]
这句代码报错" m_OpCode(lngIndex) ="怎么没附值。
[解决办法]
呵呵 收藏 有了时间再整理
[解决办法]
帮忙顶一下,让了解的人来解答.
btw:他妈的，我还是CSDN论坛首页的常驻专家门诊（JAVA板块）呢，居然在JAVA板块既不能发新贴，也不能回复。
btw:郁闷，加的好友太多了，现在加好友都是非法请求了。连好友页面也打不开。连私信页面也打不开。
btw:CSDN当时没有测试过加好友很多的情况的吗？郁闷。现在一点加好友就出错。
[解决办法]
收藏
[解决办法]
不懂，学习吧！
[解决办法]
顶顶～不错啊～
[解决办法]
谢谢，学习中。。。
[解决办法]
VB自己编的DLL能用这个动态调用吗？
[解决办法]
UP
[解决办法]
up
[解决办法]
牛的，收藏了先
[解决办法]
收藏!
------解决方案--------------------
好东西，收下了。有时间好好学习学习。
[解决办法]
给点积分吧