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

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

...全文
4159 82 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
82 条回复
切换为时间正序
请发表友善的回复…
发表回复
fzygsgsfzylsq 2012-05-24
  • 打赏
  • 举报
回复
楼主太棒了,高人。
楼里的看来也都不是凡人。
作为一个初学者的我,想高攀一下,不知肯否赏脸。求教一个问题:
如何通过vb进行并口数据的读写?我初学,尽量详细些。
gswsdut 2012-03-19
  • 打赏
  • 举报
回复
楼主V5
inatural66 2011-12-27
  • 打赏
  • 举报
回复
mark一记
若苦 2011-12-17
  • 打赏
  • 举报
回复
mark
AddDark 2011-05-06
  • 打赏
  • 举报
回复
标记一下
青蛙爱大莹宝 2011-03-29
  • 打赏
  • 举报
回复
代码 写的 的 挺 规范 的 ,学习
安静苦笑 2011-02-20
  • 打赏
  • 举报
回复
我新手..看不懂
bshkl 2010-04-08
  • 打赏
  • 举报
回复
是不是可以拿分
my13513480001 2010-02-22
  • 打赏
  • 举报
回复
陆陆续续看了看,有些语句看不懂
哪位大牛有时间能给注解一下么?(注解主要的函数就行了)
my13513480001 2010-02-16
  • 打赏
  • 举报
回复
【封装API】——13楼,占位学习!!!!
cqq_chen 2009-10-02
  • 打赏
  • 举报
回复
.
VIVI0622 2009-06-23
  • 打赏
  • 举报
回复
您知道在VB中怎么把采集到的数据实时绘制成曲线么?我看了很多程序,都不知道怎么把里面的函数变成信号发生器发出来的数据
hskt117 2009-03-14
  • 打赏
  • 举报
回复
楼主真是强人 学习了
junfle 2009-02-05
  • 打赏
  • 举报
回复
看不懂也要看
flwd2000 2008-10-29
  • 打赏
  • 举报
回复
不错
ChamPagneZ 2008-10-13
  • 打赏
  • 举报
回复
mark
siyangz 2008-10-12
  • 打赏
  • 举报
回复
asdfadfadf 2008-10-12
  • 打赏
  • 举报
回复
有意思,好好学习一下...
wangyoubei 2008-10-10
  • 打赏
  • 举报
回复
给点积分吧
dlmeijianyu 2008-10-10
  • 打赏
  • 举报
回复
好东西,收下了。有时间好好学习学习。
加载更多回复(62)

1,488

社区成员

发帖
与我相关
我的任务
社区描述
VB API
社区管理员
  • API
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧