[讨论]LISP调用DLL动态Win32Api的实现

NetBee

aroom
   发帖：实现Quicktool Win32Api For Lisp编程接口
各位高手来共同来讨论讨论，它是如何实现的呢？
在网上找了一段动态调用外部函数的VB代码。

3. Option Explicit
4. Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
5. Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
6. 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
7. Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
8. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
9. Private m_opIndex As Long '写入位置
10. Private m_OpCode() As Byte  'Assembly 的OPCODE
11. Public Function RunDll32(ByVal isUnload As Boolean, ByVal strLibFileName As String, strProcName As String, ParamArray Params()) As Long
12.     Dim hProc As Long
13.     Dim hModule As Long
14.     ReDim m_OpCode(400 + 6 * UBound(Params)) '保留用来写m_OpCode
15.     '读取API库
16.     hModule = LoadLibrary(ByVal strLibFileName)
17.     If hModule = 0 Then
18.         MsgBox "函数库Library:" + Chr(13) + strLibFileName + Chr(13) + "读取失败！"
19.         RunDll32 = 0
20.         Exit Function
21.     End If
22.    
23.     '取得函数地址
24.     hProc = GetProcAddress(hModule, ByVal strProcName)
25.     'MsgBox "参数2:" + strLibFileName + Chr(13) + "参数3:" + strProcName
26.     If hProc = 0 Then
27.        MsgBox "提示：" + Chr(13) + strProcName + Chr(13) + "函数读取失败！", vbCritical
28.        FreeLibrary hModule
29.        RunDll32 = 0
30.        Exit Function
31.     End If
32.     '执行Assembly Code部分
33.     RunDll32 = CallWindowProc(GetCodeStart(hProc, Params), 0, 1, 2, 3)
34.     '一些函数需要驻留这就先不释放
35.     If isUnload Then FreeLibrary hModule  '释放空间
36. End Function
37. 'Public Function RunDll32(LibFileName As String, ProcName As String, ParamArray Params()) As Long
38. '    Dim hProc As Long
39. '    Dim hModule As Long
40. '
41. '    ReDim m_OpCode(400 + 6 * UBound(Params)) '保留用来写m_OpCode
42. '    '读取API库
43. '    hModule = LoadLibrary(ByVal LibFileName)
44. '    If hModule = 0 Then
45. '        MsgBox "Library读取失败！"
46. '        Exit Function
47. '    End If
48. '
49. '    '取得函数地址
50. '    hProc = GetProcAddress(hModule, ByVal ProcName)
51. '    If hProc = 0 Then
52. '       MsgBox "函数读取失败！", vbCritical
53. '       FreeLibrary hModule
54. '       Exit Function
55. '    End If
56. '
57. '
58. '    '执行Assembly Code部分
59. '    RunDll32 = CallWindowProc(GetCodeStart(hProc, Params), 0, 1, 2, 3)
60. '
61. '    FreeLibrary hModule '释放空间
62. 'End Function
63. Private Function GetCodeStart(ByVal lngProc As Long, ByVal arrParams As Variant) As Long
64. '---以下为Assembly部分--
65. '作用：将函数的参数压入堆栈
66.    
67.     Dim lngIndex As Long, lngCodeStart As Long
68.    
69.     '程序起始位址必须是16的倍数
70.     'VarPtr函数是用来取得变量的地址
71.     lngCodeStart = (VarPtr(m_OpCode(0)) Or &HF) + 1
72.    
73.     m_opIndex = lngCodeStart - VarPtr(m_OpCode(0)) '程序开始的元素的位置
74.    
75.     '前面部分以中断点添满
76.     For lngIndex = 0 To m_opIndex - 1
77.         m_OpCode(lngIndex) = &HCC 'int 3
78.     Next lngIndex
79.    
80.     '--------以下开始放入所需的程序----------
81.    
82.     '将参数push到堆栈
83.     '由于是STDCall CALL 参数由最后一个开始放到堆栈
84.     For lngIndex = UBound(arrParams) To 0 Step -1
85.        AddByteToCode &H68 'push的机器码为H68
86.        AddLongToCode CLng(arrParams(lngIndex))  '参数地址
87.     Next lngIndex
88.    
89.     'call hProc
90.     AddByteToCode &HE8 'call的机器码为HE8
91.     AddLongToCode lngProc - VarPtr(m_OpCode(m_opIndex)) - 4 '函数地址 用call的定址
92.    
93.     '-----------结束所需的程序--------------
94.    
95.     '返回呼叫函數
96.     AddByteToCode &HC2 'ret 10h
97.     AddByteToCode &H10
98.     AddByteToCode &H0
99.    
100.     GetCodeStart = lngCodeStart
101. End Function
102. Private Sub AddLongToCode(lData As Long)
103. '将Long类型的参数写到m_OpCode中
104.     CopyMemory m_OpCode(m_opIndex), lData, 4
105.     m_opIndex = m_opIndex + 4
106. End Sub
107. Private Sub AddIntToCode(iData As Byte)
108. '将Integer类型的参数写道m_OpCode中
109.     CopyMemory m_OpCode(m_opIndex), iData, 2
110.     m_opIndex = m_opIndex + 2
111. End Sub
112. Private Sub AddByteToCode(bData As Byte)
113.     '将Byte类型的参数写道m_OpCode中
114.     m_OpCode(m_opIndex) = bData
115.     m_opIndex = m_opIndex + 1
116. End Sub

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，并输入：

2. Public Function test1(hWnd As Long, ByVal s1 As String, ByVal s2 As String) As Long
3.   s1 = StrConv(s1, vbFromUnicode)
4.   s2 = StrConv(s2, vbFromUnicode)
5.   test1 = RunDll32(True, "user32", "MessageBoxA", hWnd, StrPtr(s1), StrPtr(s2), 0&)
6. End Function

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中

2. (defun test1 (/ obj ret hwnd errorMsg)
3.   (setq hwnd 153)
4.   (setq obj (vlax-get-or-create-object "NBTLIBS.Win32Api"))
5.   (setq errorMsg (VL-CATCH-ALL-APPLY 'vlax-invoke-method
6.                                      (list obj "test1" 0 "内容 " "标题")
7.                  ) ;_ 结束VL-CATCH-ALL-APPLY
8.   ) ;_ 结束setq
9.   (vlax-release-object obj)
10.   (if (VL-CATCH-ALL-ERROR-P errorMsg)
11.     (princ (STRCAT "发生下列错误: "
12.                    (VL-CATCH-ALL-ERROR-MESSAGE errorMsg)
13.            ) ;_ 结束STRCAT
14.     )
15.   ) ;_ 结束if
16.   errormsg
17. ) ;_ 结束defun

(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)，就能实现对话框了。

pengfei2010

回帖是一种美德！感谢楼主的无私分享 谢谢

NetBee

但是在LISP中动态调用方面却总是因为参数类型问题无法调用成功
在VB中Win32Api类模块中输入：

Public Function Win32Api(ByVal LibFileName As String, ByVal ProcName As String, ParamArray Params1()) As Long
'Public Function Win32Api(ByVal LibFileName As String, ByVal ProcName As String, ByVal Params1 As Variant) As Long
'处理字符串变量
Dim lngIndex As Long
    For lngIndex = 0 To UBound(Params1)
      If VarType(Params1(lngIndex)) = vbString Then
        Params1(lngIndex) = StrPtr(StrConv(Params1(lngIndex), vbFromUnicode))
      End If
    Next lngIndex
  Win32Api = RunDll32(True, LibFileName, ProcName, Params1)
  '("user32", "MessageBoxA", hWnd, VarPtr(s1(0)), VarPtr(s2(0)), 0&)
End Function

然后在LISP中

2. (defun test1 (/ obj ret hwnd errorMsg)
3.   (setq hwnd 153)
4.   (setq obj (vlax-get-or-create-object "NBTLIBS.Win32Api"))
5.   (setq errorMsg (VL-CATCH-ALL-APPLY 'vlax-invoke-method
6.                                      (list obj "Win32Api" "user32" "MessageBoxA" 0 "测试内容" "标题" 0)
7.                                      ) ;_ 结束VL-CATCH-ALL-APPLY
8.   ) ;_ 结束setq
9.   (vlax-release-object obj)
10.   (if (VL-CATCH-ALL-ERROR-P errorMsg)
11.     (princ (STRCAT "发生下列错误: "
12.                    (VL-CATCH-ALL-ERROR-MESSAGE errorMsg)
13.            ) ;_ 结束STRCAT
14.     )
15.   ) ;_ 结束if
16.   errormsg
17. ) ;_ 结束defun

(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 "Win32Api" "user32" "MessageBoxA" 0 "测试内容" "标题" 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

调用却不成功！
出错信息：发生下列错误: Automation 错误。 类型不匹配

NetBee

得解决参数传递问题呀！
各位快来讨论讨论！！

liu_kunlun

我曾做过试验，但基于单变量，多变量时可用Variant解决，当时的实验总结如下,或许对你有帮助。

1、在VB中,选择创建activex dll，在右上方将修改工程名为testdll,修改类名为test1
在代码区输入下列代码：
Public Function vvvaa(ByVal a As double) As double
    vvvaa = a
End Function
用文件菜单编译成testdll.dll
于是创建了一个testdll.dll文件,其中包含一个test1类,test1类中有含Public Function vvvaa定义。

2、在autolisp中,用
(setq vvvv (vlax-create-object "testdll.test1"))
(vlax-invoke-method vvvv "vvvaa" 3)
可获得返回值3(与输入值一致)

或用

(defun vvvv ( a / vbcls out)  
   (setq vbcls
    (vlax-invoke-method
       (vlax-get-acad-object)
       "getInterfaceObject"
       "testdll.test1"
    )
   )
   (setq out
    (vlax-invoke-method vbcls "vvvaa" a)
   )
   (vlax-release-object vbcls)  
   out
)
(vvvv 30)
;;可得到返回值30(与输入值一致)

;;注意事项:
;;一、函数定义时的问题
;; 1) 函数定义时应采用Public。
;; 2) 输入参数时必须采用byval,否则输入参数传不进dll。
;; 3) 如果输入参数是一个表，可将参数定义为Variant类型。
;; 4) 如果返回参数是一个表，可将函数定义为Variant类型，返回值用array构造。
;;二、autolisp中对返回参数的处理
;;1)函数定义返回简单参数时,可直接得到结果
;;2)函数定义返回variant,且结果为简单参数时,用vlax-variant-value得到结果
;;3)函数定义返回variant,且结果为表时,
;;   用(mapcar 'vlax-variant-value (vlax-safearray->list (vlax-variant-value得到表结果
;;三、autolisp中对输入参数的处理
;;1)函数定义输入为简单参数时，可直接填入数据
;;2)函数定义输入为variant时，如输入简单参数，可直接填入数据也可用vlax-make-variant输入
;;3)函数定义输入为variant时，如输入表时，用如下示例方法：
;;   (setq aa0 (vlax-make-safearray vlax-vbVariant '(0 . 2)))
;;   (vlax-safearray-fill aa0 '(9 2 "3"))
;;   (setq aa1 (vlax-make-variant aa0 ))

virgin

非常感谢分享经验.这可是书本上学不到的东西~~~~~

hyccai

收下先，说不定会用到

yshf

感谢NetBee和liu_kunlun两高手在此提供了宝贵的经验！

菜冬瓜

学习了

nonsmall

好文章 学习中

jxphklibin

呵呵，好啊，我也做个一个，但是参数传递还没弄过，应该也没问题，哈哈，时隔三年了