我也来个VLISP直接调用WIN API函数
本帖最后由 yyzhan12 于 2022-2-2 23:53 编辑<p>Vlisp直接调用Win API通用函数：c:ysx-use-api by yyzhan12</p> 本帖最后由 baitang36 于 2024-7-15 09:15 编辑
cchessbd 发表于 2022-10-5 17:40
这不好吧，花了钱也学习不到知识。。。15年以前的老代码了，让大家看看是怎么实现的。如果作者介意，请回复，马上删除
(SETVAR "cmdecho" 0)
(DEFUN C:YSX-USE-API (CZSX APISM
APINAME CSLIST
/ C:YSX-LOAD-VBA
C:YSX-FUNCTION-API
C:YSX-USE-VBABAS C:YSX-UNLOAD-DVB
)
(DEFUN C:YSX-LOAD-VBA ()
(if (AND (= (MEMBER "acvba.arx" (ARX)) nil)
(= (MEMBER "acadvba.arx" (ARX)) nil)
)
(PROGN
(VL-CATCH-ALL-APPLY 'ARXLOAD (LIST (FINDFILE "acvba.arx")))
(VL-CATCH-ALL-APPLY
'ARXLOAD
(LIST (FINDFILE "acadvba.arx"))
)
(PRINC "\r \n")
)
)
(PRINC)
)
(DEFUN C:YSX-FUNCTION-API (APISM CZSX CSLIST APINAME
/ VARLISTFHZ CADOBJ
CADVBA BASTEXTVBAYJ DGLIST
)
(VL-LOAD-COM)
(PRINT)
(setq VARLIST (MAPCAR 'GETVAR (LIST "cmdecho" "users1")))
(MAPCAR 'SETVAR (LIST "cmdecho" "users1") (LIST 0 ""))
(setq FHZ nil)
(C:YSX-LOAD-VBA)
(if
(AND (OR (MEMBER "acvba.arx" (ARX)) (MEMBER "acadvba.arx" (ARX)))
(VL-VLX-LOADED-P "Ysx-Vlisp-WinAPI")
)
(PROGN
(setq CADOBJ (vlax-get-acad-object))
(command "_.vbanew")
(command "_.vbanew")
(setq CADVBA
(vlax-get
(vlax-get (vlax-get CADOBJ 'VBE) 'ACTIVEVBPROJECT)
'VBCOMPONENTS
)
)
(COND
((/= APISM 888)
(setq
BASTEXT (APPEND
BASTEXT
(LIST APISM
"Sub AutoCadVLispUseVbaWinSystemApi()"
"dim fhz"
"On Error Resume Next"
)
)
)
(COND
((= CSLIST nil)
(setq BASTEXT
(APPEND BASTEXT
(LIST (STRCAT "fhz = " APINAME "()"))
)
)
)
((/= CSLIST nil)
(setq VBAYJ "")
(FOREACH DGLIST CSLIST
(if (= VBAYJ "")
(PROGN (setq VBAYJ (VL-PRIN1-TO-STRING DGLIST)))
(PROGN (setq VBAYJ (STRCAT VBAYJ
","
(VL-PRIN1-TO-STRING DGLIST)
)
)
)
)
)
(while
(and
(VL-STRING-SEARCH (STRCASE "\\\\") (STRCASE VBAYJ))
)
(setq VBAYJ (VL-STRING-SUBST
"\\"
(STRCASE "\\\\")
(STRCASE VBAYJ)
)
)
)
(setq BASTEXT
(APPEND
BASTEXT
(LIST (STRCAT "fhz = " APINAME "(" VBAYJ ")")
)
)
)
)
)
(COND ((= CZSX nil)
(setq BASTEXT
(APPEND
BASTEXT
(LIST
"ThisDrawing.SetVariable \"users1\", CStr(fhz)"
)
)
)
)
((= CZSX T)
(setq BASTEXT
(APPEND
BASTEXT
(LIST
"ThisDrawing.SetVariable \"users1\", fhz"
)
)
)
)
)
(setq BASTEXT (APPEND BASTEXT (LIST "End Sub")))
(setq APINAME "AutoCadVLispUseVbaWinSystemApi")
)
((= APISM 888) (setq BASTEXT CSLIST))
)
(C:YSX-USE-VBABAS APISM CADVBA BASTEXT APINAME)
(C:YSX-UNLOAD-DVB)
(if (/= (GETVAR "users1") "")
(PROGN
(COND ((= CZSX nil) (setq FHZ (READ (GETVAR "users1"))))
((= CZSX T) (setq FHZ (GETVAR "users1")))
)
)
)
)
)
(MAPCAR 'SETVAR (LIST "cmdecho" "users1") VARLIST)
FHZ
)
(vl-ACAD-defun 'C:YSX-FUNCTION-API)
(DEFUN C:YSX-USE-VBABAS
(APISM CADVBA TEXTLIST VBANAME / WRTEXT DGLIST)
(setq WRTEXT "")
(FOREACH DGLIST TEXTLIST
(if (= WRTEXT "")
(PROGN (setq WRTEXT DGLIST))
(PROGN (setq WRTEXT (STRCAT WRTEXT "\n" DGLIST)))
)
)
(vlax-invoke-method
(vlax-get (vlax-get (vlax-get (vlax-get-acad-object) 'VBE)
'SELECTEDVBCOMPONENT
)
'CODEMODULE
)
'ADDFROMSTRING
WRTEXT
)
(VL-VBARUN (STRCAT "ThisDrawing." VBANAME))
(PRINC)
)
(vl-ACAD-defun 'C:YSX-USE-VBABAS)
(DEFUN C:YSX-UNLOAD-DVB (/ FHZ CADOBJ DVBNAME DVBZBJ)
(setq FHZ nil)
(setq CADOBJ (vlax-get-acad-object))
(setq DVBNAME
(vlax-get (vlax-get (vlax-get CADOBJ 'VBE) 'MAINWINDOW)
'CAPTION
)
)
(PRINC "\r \n")
(setq DVBZBJ "")
(COND ((VL-STRING-SEARCH (STRCASE "全局") (STRCASE DVBNAME))
(setq DVBZBJ "全局")
)
((VL-STRING-SEARCH (STRCASE "global") (STRCASE DVBNAME))
(setq DVBZBJ "global")
)
)
(if (OR (= (STRCASE DVBZBJ) (STRCASE "全局"))
(= (STRCASE DVBZBJ) (STRCASE "global"))
)
(PROGN (setq DVBNAME (READ (SUBSTR DVBNAME
(+ (VL-STRING-SEARCH
(STRCASE DVBZBJ)
(STRCASE DVBNAME)
)
(+ (STRLEN DVBZBJ) 1)
)
)
)
)
(vlax-invoke-method
CADOBJ
'UNLOADDVB
(CAR (LIST (STRCAT DVBZBJ (ITOA DVBNAME))
(vlax-invoke-method
(vlax-get-or-create-object "wscript.shell")
'SENDKEYS
(STRCAT "{N}")
)
)
)
)
(vlax-invoke-method
CADOBJ
'UNLOADDVB
(STRCAT DVBZBJ (ITOA (+ DVBNAME 1)))
)
(setq FHZ T)
)
)
FHZ
)
(vl-ACAD-defun 'C:YSX-UNLOAD-DVB)
(VL-CATCH-ALL-APPLY
'C:YSX-FUNCTION-API
(LIST APISM CZSX CSLIST APINAME)
)
)
(DEFUN C:QWERTYUIOPASDFGHJKLZXCVBNM9638527410 () T)
(if (VL-VLX-LOADED-P "Ysx-Vlisp-WinAPI")
(PROGN
(if
(/= (EQUAL (MAPCAR 'STRCASE
(VL-LIST-EXPORTED-FUNCTIONS "Ysx-Vlisp-WinAPI")
)
(MAPCAR 'STRCASE
(LIST "c:qwertyuiopasdfghjklzxcvbnm9638527410"
"c:ysx-use-api"
)
)
)
T
)
(PROGN (setq C:YSX-USE-API nil)
(setq C:YSX-LOAD-VBA nil)
(setq C:YSX-FUNCTION-API nil)
(setq C:YSX-USE-VBABAS nil)
(setq C:YSX-UNLOAD-DVB nil)
)
)
)
)
(if (= (VL-VLX-LOADED-P "Ysx-Vlisp-WinAPI") nil)
(PROGN (setq C:YSX-USE-API nil)
(setq C:YSX-LOAD-VBA nil)
(setq C:YSX-FUNCTION-API nil)
(setq C:YSX-USE-VBABAS nil)
(setq C:YSX-UNLOAD-DVB nil)
)
)
(PRINC) baitang36 发表于 2024-7-15 09:12
15年以前的老代码了，让大家看看是怎么实现的。如果作者介意，请回复，马上删除
(SETVAR "cmdecho" 0)
(D ...
一看楼主就是高手，可能都忘记这个程序了。我试了一下，可能公司电脑剪粘板的限制，用不了呀
;|http://bbs.mjtd.com/thread-74063-1-1.html
Vlisp直接调用Win API通用函数：c:ysx-use-api by yyzhan12
参数说明：
1、参数1
API返回值类型，long为nil, string为T
返回值目前仅支持long和string，其他类型的日后完善
2、参数2
API函数声明，文本
3、参数3
API函数名称
4、参数4
API函数参数表
例子：
(c:ysx-use-api nil "Private Declare Function GetCurrentProcessId Lib \"kernel32\" () As Long" "GetCurrentProcessId" nil)
获取进程标识符
(c:ysx-use-api nil "Private Declare Function ShowCursor Lib \"user32\" Alias \"ShowCursor\" (ByVal bShow As Long) As Long" "ShowCursor" (list 1))
显示鼠标
(c:ysx-use-api nil "Private Declare Function ShowCursor Lib \"user32\" Alias \"ShowCursor\" (ByVal bShow As Long) As Long" "ShowCursor" (list 0))
隐藏鼠标
(c:ysx-use-api nil "Private Declare Function CopyFile Lib \"kernel32\" Alias \"CopyFileA\" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long" "CopyFile" (list "c:\\bootfont.bin" "d:\\1.vxd" 0))
复制文件
____________________________________________________________________________________________
Vlisp直接调用Win API函数
解决了以下几个问题:
1、解决了AutoCAD退出时提示保存工程的问题。
2、解决了连续调用API时卸载工程不成功的问题
3、解决命令行多余信息显示的问题
4、解决影响其它工程的问题
5、改进Win API代码的加载方式
6、加强了程序代码反破解功能
|;
;;[加载VBA] 如果没有安装VBA，此函数没有用。
(DEFUN C:YSX-LOAD-VBA ()
(if
(AND (= (MEMBER "acvba.arx" (ARX)) nil)
(= (MEMBER "acadvba.arx" (ARX)) nil)
)
(PROGN
(VL-CATCH-ALL-APPLY 'ARXLOAD (LIST (FINDFILE "acvba.arx")))
(VL-CATCH-ALL-APPLY 'ARXLOAD (LIST (FINDFILE "acadvba.arx")))
(PRINC "\r \n")
)
)
(PRINC)
)
;;[卸载DVB]
(DEFUN C:YSX-UNLOAD-DVB (/ FHZ CADOBJ DVBNAME DVBZBJ)
(setq FHZ nil)
(setq CADOBJ (vlax-get-acad-object))
(setq DVBNAME
(vlax-get (vlax-get (vlax-get CADOBJ 'VBE) 'MAINWINDOW)
'CAPTION
)
)
(PRINC "\r \n")
(setq DVBZBJ "")
(COND ((VL-STRING-SEARCH (STRCASE "全局") (STRCASE DVBNAME))
(setq DVBZBJ "全局")
)
((VL-STRING-SEARCH (STRCASE "global") (STRCASE DVBNAME))
(setq DVBZBJ "global")
)
)
(if (OR (= (STRCASE DVBZBJ) (STRCASE "全局"))
(= (STRCASE DVBZBJ) (STRCASE "global"))
)
(PROGN (setq DVBNAME (READ (SUBSTR DVBNAME
(+ (VL-STRING-SEARCH
(STRCASE DVBZBJ)
(STRCASE DVBNAME)
)
(+ (STRLEN DVBZBJ) 1)
)
)
)
)
(vlax-invoke-method
CADOBJ
'UNLOADDVB
(CAR (LIST (STRCAT DVBZBJ (ITOA DVBNAME))
(vlax-invoke-method
(vlax-get-or-create-object "wscript.shell")
'SENDKEYS
(STRCAT "{N}")
)
)
)
)
(vlax-invoke-method
CADOBJ
'UNLOADDVB
(STRCAT DVBZBJ (ITOA (+ DVBNAME 1)))
)
(setq FHZ T)
)
)
FHZ
)
(vl-ACAD-defun 'C:YSX-UNLOAD-DVB)
;;[使用VBABAS]
(DEFUN C:YSX-USE-VBABAS (APISM CADVBA TEXTLIST VBANAME / WRTEXT DGLIST)
(setq WRTEXT "")
(FOREACH DGLIST TEXTLIST
(if (= WRTEXT "")
(setq WRTEXT DGLIST)
(setq WRTEXT (STRCAT WRTEXT "\n" DGLIST))
)
)
(vlax-invoke-method
(vlax-get
(vlax-get (vlax-get (vlax-get-acad-object) 'VBE)
'SELECTEDVBCOMPONENT
)
'CODEMODULE
)
'ADDFROMSTRING
WRTEXT
)
(VL-VBARUN (STRCAT "ThisDrawing." VBANAME))
(PRINC)
)
(vl-ACAD-defun 'C:YSX-USE-VBABAS)
;;
(DEFUN C:YSX-FUNCTION-API (APISM CZSX CSLIST APINAME/
VARLISTFHZ CADOBJ CADVBA BASTEXT
VBAYJ DGLIST
)
(VL-LOAD-COM)
(PRINT)
(setq VARLIST (MAPCAR 'GETVAR (LIST "cmdecho" "users1")))
(MAPCAR 'SETVAR (LIST "cmdecho" "users1") (LIST 0 ""))
(setq FHZ nil)
(C:YSX-LOAD-VBA)
(if
(AND (OR (MEMBER "acvba.arx" (ARX)) (MEMBER "acadvba.arx" (ARX)))
(VL-VLX-LOADED-P "Ysx-Vlisp-WinAPI")
)
(PROGN
(setq CADOBJ (vlax-get-acad-object))
(command "_.vbanew")
(command "_.vbanew")
(setq
CADVBA (vlax-get
(vlax-get (vlax-get CADOBJ 'VBE) 'ACTIVEVBPROJECT)
'VBCOMPONENTS
)
)
(COND
((/= APISM 888)
(setq BASTEXT
(APPEND BASTEXT
(LIST APISM
"Sub AutoCadVLispUseVbaWinSystemApi()"
"dim fhz"
"On Error Resume Next"
)
)
)
(COND
((= CSLIST nil)
(setq
BASTEXT (APPEND BASTEXT
(LIST (STRCAT "fhz = " APINAME "()"))
)
)
)
((/= CSLIST nil)
(setq VBAYJ "")
(FOREACH DGLIST CSLIST
(if (= VBAYJ "")
(PROGN (setq VBAYJ (VL-PRIN1-TO-STRING DGLIST)))
(PROGN
(setq
VBAYJ
(STRCAT VBAYJ "," (VL-PRIN1-TO-STRING DGLIST))
)
)
)
)
(while
(and (VL-STRING-SEARCH (STRCASE "\\\\") (STRCASE VBAYJ))
)
(setq
VBAYJ
(VL-STRING-SUBST
"\\"
(STRCASE "\\\\")
(STRCASE VBAYJ)
)
)
)
(setq BASTEXT
(APPEND
BASTEXT
(LIST (STRCAT "fhz = " APINAME "(" VBAYJ ")"))
)
)
)
)
(COND ((= CZSX nil)
(setq BASTEXT
(APPEND
BASTEXT
(LIST
"ThisDrawing.SetVariable \"users1\", CStr(fhz)"
)
)
)
)
((= CZSX T)
(setq BASTEXT
(APPEND
BASTEXT
(LIST "ThisDrawing.SetVariable \"users1\", fhz"
)
)
)
)
)
(setq BASTEXT (APPEND BASTEXT (LIST "End Sub")))
(setq APINAME "AutoCadVLispUseVbaWinSystemApi")
)
((= APISM 888) (setq BASTEXT CSLIST))
)
(C:YSX-USE-VBABAS APISM CADVBA BASTEXT APINAME)
(C:YSX-UNLOAD-DVB)
(if (/= (GETVAR "users1") "")
(PROGN
(COND ((= CZSX nil) (setq FHZ (READ (GETVAR "users1"))))
((= CZSX T) (setq FHZ (GETVAR "users1")))
)
)
)
)
)
(MAPCAR 'SETVAR (LIST "cmdecho" "users1") VARLIST)
FHZ
)
(vl-ACAD-defun 'C:YSX-FUNCTION-API)
;;主函数
(SETVAR "cmdecho" 0)
(DEFUN C:YSX-USE-API (CZSX APISM APINAME CSLIST)
(VL-CATCH-ALL-APPLY
'C:YSX-FUNCTION-API
(LIST APISM CZSX CSLIST APINAME)
)
)
;|;以下的函数几本没什么用处
(DEFUN C:QWERTYUIOPASDFGHJKLZXCVBNM9638527410 () T);用来防反编译？？
;;Ysx-Vlisp-WinAPI是此文件编译成VLX后的文件名
;;VL-LIST-EXPORTED-FUNCTIONS 返回vlx中C:定义的函数名列表
(if (VL-VLX-LOADED-P "Ysx-Vlisp-WinAPI")
(PROGN
(if
(EQUAL (MAPCAR 'STRCASE
(VL-LIST-EXPORTED-FUNCTIONS "Ysx-Vlisp-WinAPI")
)
(MAPCAR 'STRCASE
(LIST "c:qwertyuiopasdfghjklzxcvbnm9638527410"
"c:ysx-use-api"
)
)
)
nil
(PROGN
(setq C:YSX-USE-API nil)
(setq C:YSX-LOAD-VBA nil)
(setq C:YSX-FUNCTION-API nil)
(setq C:YSX-USE-VBABAS nil)
(setq C:YSX-UNLOAD-DVB nil)
)
)
)
)
(if (VL-VLX-LOADED-P "Ysx-Vlisp-WinAPI")
nil
(PROGN
(setq C:YSX-USE-API nil)
(setq C:YSX-LOAD-VBA nil)
(setq C:YSX-FUNCTION-API nil)
(setq C:YSX-USE-VBABAS nil)
(setq C:YSX-UNLOAD-DVB nil)
)
)
|;
(PRINC) 自贡黄明儒 发表于 2024-7-19 15:22
一看楼主就是高手，可能都忘记这个程序了。我试了一下，可能公司电脑剪粘板的限制，用不了呀
想试试作者是否已经退出江湖了 本帖最后由 yyzhan12 于 2010-12-5 19:30 编辑 <br /><br /><P>Vlisp直接调用Win API通用函数：c:ysx-use-api by yyzhan12</P>
<P>参数说明：</P>
<P>1、参数1</P>
<P>API返回值类型，long为nil, string为T</P>
<P>返回值目前仅支持long和string，其他类型的日后完善</P>
<P>2、参数2</P>
<P>API函数声明，文本</P>
<P>3、参数3 </P>
<P>API函数名称</P>
<P>4、参数4</P>
<P>API函数参数表</P>
<P>例子：</P>
<P>(c:ysx-use-api nil "Private Declare Function GetCurrentProcessId Lib \"kernel32\" () As Long" "GetCurrentProcessId" nil)</P>
<P>获取进程标识符</P>
<P>(c:ysx-use-api nil "Private Declare Function ShowCursor Lib \"user32\" Alias \"ShowCursor\" (ByVal bShow As Long) As Long" "ShowCursor" (list 1))</P>
<P>显示鼠标</P>
<P>(c:ysx-use-api nil "Private Declare Function ShowCursor Lib \"user32\" Alias \"ShowCursor\" (ByVal bShow As Long) As Long" "ShowCursor" (list 0))</P>
<P>隐藏鼠标</P>
<P>(c:ysx-use-api nil "Private Declare Function CopyFile Lib \"kernel32\" Alias \"CopyFileA\" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long" "CopyFile" (list "c:\\bootfont.bin" "d:\\1.vxd" 0))</P>
<P>复制文件</P>
<P><BR>____________________________________________________________________________________________</P>
<P>Vlisp直接调用Win API函数</P>
<P>解决了以下几个问题:</P>
<P>1、解决了AutoCAD退出时提示保存工程的问题。</P>
<P>2、解决了连续调用API时卸载工程不成功的问题</P>
<P>3、解决命令行多余信息显示的问题</P>
<P>4、解决影响其它工程的问题</P>
<P>5、改进Win API代码的加载方式</P>
<P>6、加强了程序代码反破解功能</P>
<P>____________________________________________________________________________________________</P>
<P>程序已更新 2009-4-4</P> 本帖最后由 作者 于 2009-4-16 9:51:20 编辑 <br /><br /> <p>不错不错</p><p>终于有人明白了 呵呵</p><p>核心的秘密已经揭晓 感兴趣的朋友可以参考研究：</p><p><a href="http://www.mjtd.com/BBS/dispbbs.asp?BoardID=3&replyID=115948&id=72145&skin=0">http://www.mjtd.com/BBS/dispbbs.asp?BoardID=3&replyID=115948&id=72145&skin=0</a></p> nonsmall发表于2009-3-5 8:42:00static/image/common/back.gif不错不错终于有人明白了 呵呵咱们讨论一下最后关闭AutoCAD的时候会有个是否保存工程的提示另外没有alert的话 你这个程序一定会有不好使的情况这几个问题怎么解决?
<p></p><p>1、最后关闭AutoCAD的时候会有个是否保存工程的提示</p><p>这个暂时没想到怎么解决，这是美中不足，多多少少留下了手尾，明白人一看就知道怎么回事了，我想你的程序之前没放出来是不是有这方面的原因。</p>2、另外没有alert的话 你这个程序一定会有不好使的情况<p>这个不是问题，这是关于返回值的处理问题，在你帖子我已经提出了几种方法，隐蔽性做到无痕迹最好不过了</p><p>3、在你的帖子中给出的提示，可能让不少人做了很多无用功，因为关键语句就是两条，之前也想过这种方法，我想用过VBA的人应该也会</p><p>想过，以前用add不成功，就没细想了，不过你的“ <a title="《VLisp开发小助手2009贺岁版(对象查看修改+代码自动生成)》
作者：nonsmall
发表于：2008-12-15 9:32:00
最后发贴：看一下，好象有..." href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=72611"><font color="#000000">VLisp开发小助手</font></a>”真的很实用。要想用VLISP做扩展，那就要用好vlax-invoke-method</p> <p>保存的提示我有下面的尝试:</p><p>1是程序结束之前把工程保存一下 可以做到退出AUTOCAD不提示</p><p>(但我没保存成功)</p><p>2是程序结束前使用命令VBAUNLOAD但是会弹出提示框询问</p><p>(我尝试使用Sendkeys操作该提示框 有时可以 有时不可 奇也怪哉)</p><p>我之所以还没放出来 因为我抽空在研究Vlx封装VBA窗体 这个已经实现了</p> 本帖最后由 作者 于 2009-3-11 21:48:10 编辑 <br /><br /> <p>请转至1楼</p> <p>厉害,啊,神啊,无敌啊,NON哥,太厉害啦,</p><p></p> 本帖最后由 作者 于 2009-3-5 17:07:56 编辑 <br /><br /> nonsmall发表于2009-3-5 13:53:00static/image/common/back.gif保存的提示我有下面的尝试:1是程序结束之前把工程保存一下 可以做到退出AUTOCAD不提示(但我没保存成功)2是程序结束前使用命令VBAUNLOAD但是会弹出提示框询问(我尝试使用Sendkeys操作该提示框 有
<p>Vlx封装VBA窗体，和调用API有何区别？</p> 本帖最后由 作者 于 2009-3-5 17:24:52 编辑 <br /><br /> <p>我已经找出API部分的破解方法了:</p><p>Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long<br/>Sub AutoCadVLispUseVbaSystemApi()<br/>msgbox "当前Acad程序的PID(进程标识符)为:" & CStr(GetCurrentProcessId()), vbInformation, "Vlisp调用API函数"<br/>End Sub</p><p></p> 和你的有什么异同的地方没有？