楼主能否留下QQ号码，想请教问题
学习.......
相当的厉害
权限太高了
看来有必要学习一下vba
晕 权限还不够
多谢大神分享，学习一下！
这不好吧，花了钱也学习不到知识。。。
本帖最后由 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)