设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › SLdesign V3.0-lisp安装文件拖入（或复制->粘贴）绘图 ...
12下一页
返回列表 发新帖
查看: 887|回复: 16

[经验] SLdesign V3.0-lisp安装文件拖入（或复制->粘贴）绘图区安装

[复制链接]
尘缘一生
发表于 2024-7-30 22:06:09 | 显示全部楼层 |阅读模式
本帖最后由 尘缘一生 于 2024-7-30 22:13 编辑

如题：新写一个此功能展示，作为补充安装办法之一。
SLdesign V3.0-lisp安装文件拖入（或复制->粘贴）绘图区自动安装
  2. ;;字符串转表 str 字符串   sign 分割符号----(一级)---------
  3. ;;(str->lst "1 2 3 4" " ")->("1" "2" "3" "4")
  4. ;;(str->lst "毛泽东;88;xy;z" ";")->("毛泽东" "88" "xy" "z")
  5. ;;(str->lst "毛泽东;88;xy;z" "泽东")->("毛" ";88;xy;z")
  6. (defun str->lst (str sign / lst n1 n2 str_1 m2)
  7.   (setq lst '())
  8.   (setq n1 (strlen str))
  9.   (setq n2 (strlen sign))
  10.   (while (setq m2 (vl-string-search sign str))
  11.     (setq str_1 (substr str 1 m2))
  12.     (setq str (substr str (+ 1 m2 n2)))
  13.     (if (/= str_1 "")
  14.       (setq lst (cons str_1 lst))
  15.     )
  16.   )
  17.   (if (/= str "")
  18.     (setq lst (cons str lst))
  19.   )
  20.   (reverse lst)
  21. )
  22. ;;倒置字符串--(一级)-----------
  23. (defun slreverstr (str / a b)
  24.   (setq b "")
  25.   (while (> str "")
  26.     (if (< (ascii (substr str 1 1)) 129)
  27.       (setq b (strcat (substr str 1 1) b) str (substr str 2))
  28.       (setq b (strcat (substr str 1 2) b) str (substr str 3))
  29.     )
  30.   )
  31.   b
  32. )
  33. ;;去除路径最后 "\"---(一级)-----
  34. (defun slpath (str / len)
  35.   (setq str (strcase (slreverstr str)))
  36.   (setq len (strlen str))
  37.   (while (= (substr str 1 1) "\")
  38.     (setq str (substr str 2 (- len 1)))
  39.   )
  40.   (setq str (slreverstr str))
  41.   str
  42. )
  43. ;;添加文件夹到AutoCAD支持搜索路径中的指定位置----(一级)---
  44. ;;(addsearchs sl-path0 2) 第二个后面
  45. ;;(addsearchs sl-path0 nil) 最后
  46. ;;(addsearchs sl-path0 0) 最前
  47. (defun addsearchs (dir pos / tmp c)
  48.   (setq tmp "" c -1)
  49.   (if (not pos)
  50.     (setq tmp (strcat (getenv "ACAD") ";" dir ";"))
  51.     (progn
  52.       (mapcar
  53.         '(lambda (x)
  54.            (setq tmp
  55.              (if (= (setq c (1+ c)) pos)
  56.                (strcat tmp ";" dir ";" x)
  57.                (strcat tmp ";" x)
  58.              )
  59.            )
  60.          )
  61.         (str->lst (getenv "ACAD") ";")
  62.       )
  63.       (setq tmp (strcat (substr tmp 2 (- (strlen tmp) 1)) ";"))
  64.     )
  65.   )
  66.   (setenv "ACAD" tmp)
  67.   (princ)
  68. )
  69. ;;在启动组加入------------
  70. ;(addtostartupsuite "D:\\三领设计\\main.vlx")
  71. (defun addtostartupsuite (appname / $akey $skey n i k)
  72.   (setq
  73.     $skey (strcat "HKEY_CURRENT_USER\" (vlax-product-key) "\\Profiles\" (getvar "CPROFILE") "\\Dialogs\\Appload\\Startup")
  74.     $akey (strcat "HKEY_CURRENT_USER\" (vlax-product-key) "\\Applications\\AcadAppload")
  75.   )
  76.   (setq n (vl-registry-read $skey "NumStartup") i 0 k t)
  77.   (repeat (atoi n)
  78.     (setq i (1+ i))
  79.     (if (= appname (vl-registry-read $skey (strcat (itoa i) "Startup"))) (setq k nil))
  80.   )
  81.   (if k ;无有加
  82.     (progn
  83.       (vl-registry-write $skey "NumStartup" (setq new-n (itoa (1+ (atoi n)))));修改启动组数量
  84.       (vl-registry-write $skey (strcat new-n "Startup") path);添加到启动组
  85.     )
  86.   )
  87.   ;;读取LoadCtrls的值,将这个值与2作“或”运算，再写回。这样可以保证AutoCAD启动时会加载Appload.arx模块。
  88.   (if (setq n (vl-registry-read $akey "LOADCTRLS"))
  89.     (vl-registry-write $akey "LOADCTRLS" (Boole 7 n 2))
  90.     (vl-registry-write $akey "LOADCTRLS" 15)
  91.   )
  92. )
  93. ;;是否在启动组中,有返回路径,无,返回nil
  94. ;;(car (slappload-filepath "D:\\三领设计\\main.VLX"))
  95. (defun slappload-filepath (appname / $skey i keyvalue numstartup svlst)
  96.   (if (member (type appname) '(STR SYM))
  97.     (progn
  98.       (setq $skey (strcat "HKEY_CURRENT_USER\" (vlax-product-key) "\\Profiles\" (getvar "CPROFILE") "\\Dialogs\\Appload\\Startup"))
  99.       (setq numstartup (vl-registry-read $skey "NumStartup"))
  100.       (if (= (type numstartup) 'STR)
  101.         (progn
  102.           (setq  numstartup (atoi numstartup) i 1)
  103.           (repeat numstartup
  104.             (if  (setq keyvalue (vl-registry-read $skey (strcat (itoa i) "Startup")))
  105.               (setq svlst (append svlst (list keyvalue)) i (1+ i))
  106.               (setq i (1+ i))
  107.             )
  108.           )
  109.           (if svlst
  110.             (setq svlst (mapcar 'strcase svlst))
  111.           )
  112.         )
  113.       )
  114.       (member (strcase appname) svlst)
  115.     )
  116.   )
  117. )
  118. ;将此文件拖入(或复制->粘贴)到ACAD绘图区即会自动安装
  119. (defun install (/ sl-env slst n str kk kk1 m1 m2 i path)
  120.   (vl-load-com)
  121.   (print (getvar "lastprompt"))
  122.   (setq sl-path0 (strcase (getvar "lastprompt"))) ;(LOAD "D:/SLDESIGN/将此文件拖入(或复制-粘贴)到ACAD绘图区即会自动安装.LSP")
  123.   (if (wcmatch sl-path0 "*:*\(LOAD "?:*.LSP"\)")
  124.     (setq sl-path0 (reverse (cdr (member (car (vl-string->list """)) (vl-string->list sl-path0))))
  125.       sl-path0 (vl-list->string (reverse (cdr (member (car (vl-string->list "/")) sl-path0))))
  126.       sl-path0 (vl-string-translate "/" "\" sl-path0)
  127.       sl-path0 (if (findfile (strcat sl-path0 "\\main.vlx")) sl-path0 nil)
  128.     )
  129.     (setq sl-path0 nil)
  130.   ) ;"D:\\SLDESIGN" 求得
  131.   (if (not sl-path0)
  132.     (cond
  133.       ((findfile (strcase "D:\\SLdesign\\main.vlx")) (setq sl-path0 "D:\\SLdesign"))
  134.       ((findfile (strcase "D:\\三领设计\\main.vlx")) (setq sl-path0 "D:\\三领设计"))
  135.       ((findfile (strcase "D:\\烩砞璸\\main.vlx")) (setq sl-path0 "D:\\烩砞璸"))
  136.       ((findfile "main.VLX") (setq sl-path0 (vl-filename-directory (findfile "main.VLX"))))
  137.     )
  138.   )
  139.   (if (and sl-path0 (findfile (strcat sl-path0 "\" "main.vlx")))
  140.     (progn
  141.       (setq sl-env (strcase (getenv "ACAD")));;查找支持路径
  142.       (setq slst (str->lst sl-env ";") i (abs (- (length slst) 4)))
  143.       (setq str (slreverstr (car slst)))
  144.       (if (= (substr str 1 1) "\") ;;如果路径后边带\\
  145.         (setq str "\")
  146.         (setq str "")
  147.       )
  148.       (if (or (wcmatch sl-env "*三领设计*") (wcmatch sl-env "*烩砞璸*") (wcmatch sl-env (strcase "*sldesign*")))
  149.         (while slst
  150.           (setq n (car slst))
  151.           (if (or (wcmatch n "*三领设计*") (wcmatch n "*烩砞璸*") (wcmatch n (strcase "*SLdesign*")))
  152.             (progn
  153.               (if (not (wcmatch n (strcase "*Fonts*"))) (setq sl-path0 (slpath n)))
  154.               (if (wcmatch n (strcase "*Fonts*")) (setq path (slpath n)))
  155.               (if (and sl-path0 (findfile (strcat sl-path0 "\" "main.vlx"))) (setq kk t))
  156.               (if (and path (findfile (strcat path "\" "Slhztxt.shx"))) (setq kk1 t))
  157.             )
  158.           )
  159.           (setq slst (cdr slst))
  160.         )
  161.       )
  162.       (if (= kk nil) (addsearchs (strcat sl-path0 str) i))
  163.       (if (= kk1 nil) (addsearchs (strcat sl-path0 "\\Fonts" str) i))
  164.       (if (= (slappload-filepath (strcat sl-path0 "\" "main.VLX") ) nil) ;无启动组,尝试加启动组
  165.         (vl-catch-all-apply '(lambda () (addtostartupsuite (strcat sl-path0 "\" "main.VLX") ))) ;尝试加入启动组,可能失败
  166.       )
  167.       (load (strcat sl-path0 "\" "main.vlx"))
  168.     )
  169.   )
  170. )
  171. (install)



似乎论坛发代码功能，有误了。

SLdesign V3.0

链接：https://pan.baidu.com/s/1s1XneKS9KJEMExJT1dudVg
提取码：aqhv



本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 2明经币 +2 收起 理由
baitang36 + 1 很给力!
tranque + 1 很给力!

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

LuckyClover
发表于 2024-7-30 22:20:39 | 显示全部楼层
感谢，这是付费使用的吗

点评

尘缘一生
不用目前  发表于 2024-7-30 22:27
回复 支持 反对

使用道具 举报

jh3030912
发表于 2024-7-31 07:23:06 来自手机 | 显示全部楼层
免费使用功能最多的插件
回复 支持 反对

使用道具 举报

bai2000
发表于 2024-7-31 07:39:31 | 显示全部楼层
本帖最后由 bai2000 于 2024-7-31 07:40 编辑

经常调试lisp，能不能做个程序，让放在特定文件夹中的lisp在修改后 再次刷新cad能自动重新加载修改后的程序？

点评

尘缘一生
三领就支持，专门为用户定制一个文件夹，只要用户程序放进去，就启动自动加载，基本插件都有这功能的。 也就是，支持用户自由扩展....  发表于 2024-7-31 22:42
回复 支持 反对

使用道具 举报

tranque
发表于 2024-7-31 09:31:24 | 显示全部楼层
支持尘缘大佬，感谢分享

点评

尘缘一生
我将继续打造成完美的工具箱，为此不懈努力了31年了。  发表于 2024-7-31 22:45
回复 支持 反对

使用道具 举报

aumyshow
发表于 2024-7-31 12:50:30 | 显示全部楼层
本帖最后由 aumyshow 于 2024-7-31 12:56 编辑

前几天，三个版共装好几遍都装不上；已成功装上，提示超过试用次数，注册？

点评

尘缘一生
只不过是广告罢了，最终，就会全免费了。  发表于 2024-7-31 13:44
尘缘一生
安装问题，经过研究啊，已解决BUG，关于提示的次数啊，注册，不用管，直接用即可。  发表于 2024-7-31 13:43
回复 支持 反对

使用道具 举报

sachindkini
发表于 2024-7-31 13:59:56 | 显示全部楼层
dear sir
Thanks for sharing
回复 支持 反对

使用道具 举报

aumyshow
发表于 2024-7-31 16:31:33 | 显示全部楼层
本帖最后由 aumyshow 于 2024-7-31 16:35 编辑
aumyshow 发表于 2024-7-31 12:50
前几天，三个版共装好几遍都装不上；已成功装上，提示超过试用次数，注册？

看了一下是极具个人风格的工具箱，就是这个试用提醒影响到测试

点评

尘缘一生
画图纸的我写的，你说呢？当然，有点难度，不好入门，因为已经很多年轻人不知道这种画图方式了。  发表于 2024-7-31 22:44
回复 支持 反对

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 12:43 , Processed in 0.195721 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表