SLdesign V3.0-lisp安装文件拖入（或复制->粘贴）绘图区安装
本帖最后由 尘缘一生 于 2024-7-30 22:13 编辑如题：新写一个此功能展示，作为补充安装办法之一。
SLdesign V3.0-lisp安装文件拖入（或复制->粘贴）绘图区自动安装
;;字符串转表 str 字符串 sign 分割符号----(一级)---------
;;(str->lst "1 2 3 4" " ")->("1" "2" "3" "4")
;;(str->lst "毛泽东;88;xy;z" ";")->("毛泽东" "88" "xy" "z")
;;(str->lst "毛泽东;88;xy;z" "泽东")->("毛" ";88;xy;z")
(defun str->lst (str sign / lst n1 n2 str_1 m2)
(setq lst '())
(setq n1 (strlen str))
(setq n2 (strlen sign))
(while (setq m2 (vl-string-search sign str))
(setq str_1 (substr str 1 m2))
(setq str (substr str (+ 1 m2 n2)))
(if (/= str_1 "")
(setq lst (cons str_1 lst))
)
)
(if (/= str "")
(setq lst (cons str lst))
)
(reverse lst)
)
;;倒置字符串--(一级)-----------
(defun slreverstr (str / a b)
(setq b "")
(while (> str "")
(if (< (ascii (substr str 1 1)) 129)
(setq b (strcat (substr str 1 1) b) str (substr str 2))
(setq b (strcat (substr str 1 2) b) str (substr str 3))
)
)
b
)
;;去除路径最后 "\\"---(一级)-----
(defun slpath (str / len)
(setq str (strcase (slreverstr str)))
(setq len (strlen str))
(while (= (substr str 1 1) "\\")
(setq str (substr str 2 (- len 1)))
)
(setq str (slreverstr str))
str
)
;;添加文件夹到AutoCAD支持搜索路径中的指定位置----(一级)---
;;(addsearchs sl-path0 2) 第二个后面
;;(addsearchs sl-path0 nil) 最后
;;(addsearchs sl-path0 0) 最前
(defun addsearchs (dir pos / tmp c)
(setq tmp "" c -1)
(if (not pos)
(setq tmp (strcat (getenv "ACAD") ";" dir ";"))
(progn
(mapcar
'(lambda (x)
(setq tmp
(if (= (setq c (1+ c)) pos)
(strcat tmp ";" dir ";" x)
(strcat tmp ";" x)
)
)
)
(str->lst (getenv "ACAD") ";")
)
(setq tmp (strcat (substr tmp 2 (- (strlen tmp) 1)) ";"))
)
)
(setenv "ACAD" tmp)
(princ)
)
;;在启动组加入------------
;(addtostartupsuite "D:\\三领设计\\main.vlx")
(defun addtostartupsuite (appname / $akey $skey n i k)
(setq
$skey (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" (getvar "CPROFILE") "\\Dialogs\\Appload\\Startup")
$akey (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Applications\\AcadAppload")
)
(setq n (vl-registry-read $skey "NumStartup") i 0 k t)
(repeat (atoi n)
(setq i (1+ i))
(if (= appname (vl-registry-read $skey (strcat (itoa i) "Startup"))) (setq k nil))
)
(if k ;无有加
(progn
(vl-registry-write $skey "NumStartup" (setq new-n (itoa (1+ (atoi n)))));修改启动组数量
(vl-registry-write $skey (strcat new-n "Startup") path);添加到启动组
)
)
;;读取LoadCtrls的值,将这个值与2作“或”运算，再写回。这样可以保证AutoCAD启动时会加载Appload.arx模块。
(if (setq n (vl-registry-read $akey "LOADCTRLS"))
(vl-registry-write $akey "LOADCTRLS" (Boole 7 n 2))
(vl-registry-write $akey "LOADCTRLS" 15)
)
)
;;是否在启动组中,有返回路径,无,返回nil
;;(car (slappload-filepath "D:\\三领设计\\main.VLX"))
(defun slappload-filepath (appname / $skey i keyvalue numstartup svlst)
(if (member (type appname) '(STR SYM))
(progn
(setq $skey (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" (getvar "CPROFILE") "\\Dialogs\\Appload\\Startup"))
(setq numstartup (vl-registry-read $skey "NumStartup"))
(if (= (type numstartup) 'STR)
(progn
(setqnumstartup (atoi numstartup) i 1)
(repeat numstartup
(if(setq keyvalue (vl-registry-read $skey (strcat (itoa i) "Startup")))
(setq svlst (append svlst (list keyvalue)) i (1+ i))
(setq i (1+ i))
)
)
(if svlst
(setq svlst (mapcar 'strcase svlst))
)
)
)
(member (strcase appname) svlst)
)
)
)
;将此文件拖入(或复制->粘贴)到ACAD绘图区即会自动安装
(defun install (/ sl-env slst n str kk kk1 m1 m2 i path)
(vl-load-com)
(print (getvar "lastprompt"))
(setq sl-path0 (strcase (getvar "lastprompt"))) ;(LOAD "D:/SLDESIGN/将此文件拖入(或复制-粘贴)到ACAD绘图区即会自动安装.LSP")
(if (wcmatch sl-path0 "*:*\(LOAD \"?:*.LSP\"\)")
(setq sl-path0 (reverse (cdr (member (car (vl-string->list "\"")) (vl-string->list sl-path0))))
sl-path0 (vl-list->string (reverse (cdr (member (car (vl-string->list "/")) sl-path0))))
sl-path0 (vl-string-translate "/" "\\" sl-path0)
sl-path0 (if (findfile (strcat sl-path0 "\\main.vlx")) sl-path0 nil)
)
(setq sl-path0 nil)
) ;"D:\\SLDESIGN" 求得
(if (not sl-path0)
(cond
((findfile (strcase "D:\\SLdesign\\main.vlx")) (setq sl-path0 "D:\\SLdesign"))
((findfile (strcase "D:\\三领设计\\main.vlx")) (setq sl-path0 "D:\\三领设计"))
((findfile (strcase "D:\\烩砞璸\\main.vlx")) (setq sl-path0 "D:\\烩砞璸"))
((findfile "main.VLX") (setq sl-path0 (vl-filename-directory (findfile "main.VLX"))))
)
)
(if (and sl-path0 (findfile (strcat sl-path0 "\\" "main.vlx")))
(progn
(setq sl-env (strcase (getenv "ACAD")));;查找支持路径
(setq slst (str->lst sl-env ";") i (abs (- (length slst) 4)))
(setq str (slreverstr (car slst)))
(if (= (substr str 1 1) "\\") ;;如果路径后边带\\
(setq str "\\")
(setq str "")
)
(if (or (wcmatch sl-env "*三领设计*") (wcmatch sl-env "*烩砞璸*") (wcmatch sl-env (strcase "*sldesign*")))
(while slst
(setq n (car slst))
(if (or (wcmatch n "*三领设计*") (wcmatch n "*烩砞璸*") (wcmatch n (strcase "*SLdesign*")))
(progn
(if (not (wcmatch n (strcase "*Fonts*"))) (setq sl-path0 (slpath n)))
(if (wcmatch n (strcase "*Fonts*")) (setq path (slpath n)))
(if (and sl-path0 (findfile (strcat sl-path0 "\\" "main.vlx"))) (setq kk t))
(if (and path (findfile (strcat path "\\" "Slhztxt.shx"))) (setq kk1 t))
)
)
(setq slst (cdr slst))
)
)
(if (= kk nil) (addsearchs (strcat sl-path0 str) i))
(if (= kk1 nil) (addsearchs (strcat sl-path0 "\\Fonts" str) i))
(if (= (slappload-filepath (strcat sl-path0 "\\" "main.VLX") ) nil) ;无启动组,尝试加启动组
(vl-catch-all-apply '(lambda () (addtostartupsuite (strcat sl-path0 "\\" "main.VLX") ))) ;尝试加入启动组,可能失败
)
(load (strcat sl-path0 "\\" "main.vlx"))
)
)
)
(install)
似乎论坛发代码功能，有误了。
SLdesign V3.0
链接：https://pan.baidu.com/s/1s1XneKS9KJEMExJT1dudVg
提取码：aqhv
感谢，这是付费使用的吗 感谢分享...... 免费使用功能最多的插件 本帖最后由 bai2000 于 2024-7-31 07:40 编辑
经常调试lisp，能不能做个程序，让放在特定文件夹中的lisp在修改后 再次刷新cad能自动重新加载修改后的程序？ 感谢分享...... 支持尘缘大佬，感谢分享 本帖最后由 aumyshow 于 2024-7-31 12:56 编辑
前几天，三个版共装好几遍都装不上；已成功装上，提示超过试用次数，注册？
dear sir
Thanks for sharing 本帖最后由 aumyshow 于 2024-7-31 16:35 编辑
aumyshow 发表于 2024-7-31 12:50
前几天，三个版共装好几遍都装不上；已成功装上，提示超过试用次数，注册？
看了一下是极具个人风格的工具箱，就是这个试用提醒影响到测试
页:
[1]
2