- 积分
- 6455
- 明经币
- 个
- 注册时间
- 2002-7-30
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
本帖最后由 作者 于 2007-6-10 20:31:20 编辑
aroom
发帖:实现Quicktool Win32Api For Lisp编程接口
各位高手来共同来讨论讨论,它是如何实现的呢?
在网上找了一段动态调用外部函数的VB代码。- Option Explicit
- Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
- Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
- Public 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
- Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
- Public 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 'Assembly 的OPCODE
- Public Function RunDll32(ByVal isUnload As Boolean, ByVal strLibFileName As String, strProcName As String, ParamArray Params()) As Long
- Dim hProc As Long
- Dim hModule As Long
- ReDim m_OpCode(400 + 6 * UBound(Params)) '保留用来写m_OpCode
- '读取API库
- hModule = LoadLibrary(ByVal strLibFileName)
- If hModule = 0 Then
- MsgBox "函数库Library:" + Chr(13) + strLibFileName + Chr(13) + "读取失败!"
- RunDll32 = 0
- Exit Function
- End If
-
- '取得函数地址
- hProc = GetProcAddress(hModule, ByVal strProcName)
- 'MsgBox "参数2:" + strLibFileName + Chr(13) + "参数3:" + strProcName
- If hProc = 0 Then
- MsgBox "提示:" + Chr(13) + strProcName + Chr(13) + "函数读取失败!", vbCritical
- FreeLibrary hModule
- RunDll32 = 0
- Exit Function
- End If
- '执行Assembly Code部分
- RunDll32 = CallWindowProc(GetCodeStart(hProc, Params), 0, 1, 2, 3)
- '一些函数需要驻留这就先不释放
- If isUnload Then FreeLibrary hModule '释放空间
- End Function
- 'Public Function RunDll32(LibFileName As String, ProcName As String, ParamArray Params()) As Long
- ' Dim hProc As Long
- ' Dim hModule As Long
- '
- ' ReDim m_OpCode(400 + 6 * UBound(Params)) '保留用来写m_OpCode
- ' '读取API库
- ' hModule = LoadLibrary(ByVal LibFileName)
- ' If hModule = 0 Then
- ' MsgBox "Library读取失败!"
- ' Exit Function
- ' End If
- '
- ' '取得函数地址
- ' hProc = GetProcAddress(hModule, ByVal ProcName)
- ' If hProc = 0 Then
- ' MsgBox "函数读取失败!", vbCritical
- ' FreeLibrary hModule
- ' Exit Function
- ' End If
- '
- '
- ' '执行Assembly Code部分
- ' RunDll32 = CallWindowProc(GetCodeStart(hProc, Params), 0, 1, 2, 3)
- '
- ' FreeLibrary hModule '释放空间
- 'End Function
- Private Function GetCodeStart(ByVal lngProc As Long, ByVal arrParams As Variant) As Long
- '---以下为Assembly部分--
- '作用:将函数的参数压入堆栈
-
- Dim lngIndex As Long, lngCodeStart As Long
-
- '程序起始位址必须是16的倍数
- 'VarPtr函数是用来取得变量的地址
- 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 'int 3
- Next lngIndex
-
- '--------以下开始放入所需的程序----------
-
- '将参数push到堆栈
- '由于是STDCall CALL 参数由最后一个开始放到堆栈
- For lngIndex = UBound(arrParams) To 0 Step -1
- AddByteToCode &H68 'push的机器码为H68
- AddLongToCode CLng(arrParams(lngIndex)) '参数地址
- Next lngIndex
-
- 'call hProc
- AddByteToCode &HE8 'call的机器码为HE8
- AddLongToCode lngProc - VarPtr(m_OpCode(m_opIndex)) - 4 '函数地址 用call的定址
-
- '-----------结束所需的程序--------------
-
- '返回呼叫函數
- AddByteToCode &HC2 'ret 10h
- AddByteToCode &H10
- AddByteToCode &H0
-
- GetCodeStart = lngCodeStart
- End Function
- Private Sub AddLongToCode(lData As Long)
- '将Long类型的参数写到m_OpCode中
- CopyMemory m_OpCode(m_opIndex), lData, 4
- m_opIndex = m_opIndex + 4
- End Sub
- Private Sub AddIntToCode(iData As Byte)
- '将Integer类型的参数写道m_OpCode中
- CopyMemory m_OpCode(m_opIndex), iData, 2
- m_opIndex = m_opIndex + 2
- End Sub
- Private Sub AddByteToCode(bData As Byte)
- '将Byte类型的参数写道m_OpCode中
- m_OpCode(m_opIndex) = bData
- m_opIndex = m_opIndex + 1
- End Sub
在VB中新建DLL工程命令如:nbtlibs,然后新建一个模块命令如:CallAPIbyName,将上面代码输入。然后再新建一类模块命令如:Win32Api,并输入:- Public Function test1(hWnd As Long, ByVal s1 As String, ByVal s2 As String) As Long
- s1 = StrConv(s1, vbFromUnicode)
- s2 = StrConv(s2, vbFromUnicode)
- test1 = RunDll32(True, "user32", "MessageBoxA", hWnd, StrPtr(s1), StrPtr(s2), 0&)
- End Function
在VB中最后生成DLL文件,将其复制到你需要的目录,如D:\
然后在windows的命令运行窗口(Ctrl+R)中运行:Regsvr32 d:\nbtlibs.dll,这样DLL就在windows中注册成功了。
然后在CAD的VLISP中- (defun test1 (/ obj ret hwnd errorMsg)
- (setq hwnd 153)
- (setq obj (vlax-get-or-create-object "NBTLIBS.Win32Api"))
- (setq errorMsg (VL-CATCH-ALL-APPLY 'vlax-invoke-method
- (list obj "test1" 0 "内容 " "标题")
- ) ;_ 结束VL-CATCH-ALL-APPLY
- ) ;_ 结束setq
- (vlax-release-object obj)
- (if (VL-CATCH-ALL-ERROR-P errorMsg)
- (princ (STRCAT "发生下列错误: "
- (VL-CATCH-ALL-ERROR-MESSAGE errorMsg)
- ) ;_ 结束STRCAT
- )
- ) ;_ 结束if
- errormsg
- ) ;_ 结束defun
然后运行(test1),就能实现对话框了。
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有账号?注册
x
|