726613 发表于 2013-4-10 11:15:28

CAD二次开发程序包


      图一

图二

图三

;;;部分代码转自mjtd
;;; 判断是否加载本文件
(if (car (atoms-family 1 '("vl-load-com")))
(vl-load-com)
(progn
    (Alert
      "这个程序集是为AutoCAD 2000以及更高的版本设计的，有些功能有可能在没有Visual Lisp for R14支持的AutoCAD R14上不能正确地运行。"
    )
    (exit)    ; 版本不符，退出加载。
)
)

;;; 取得本程序的路径
(defun GetPath (AppID)
(vl-registry-read
    (strcat
      "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\"
      AppID
      "_is1"
    )
    "Inno Setup: App Path"
)
)
(defun GetmylyPath () (GetPath "xzh"))

;;; 解析字符串为表
(defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
    (setq n 1)
    (setq char (substr SearchStr 1 1))
    (while (and (/= char Delimiter) (/= char ""))
      (setq n (1+ n))
      (setq char (substr SearchStr n 1))
    )
    (setq return (cons (substr SearchStr 1 (1- n)) return))
    (setq SearchStr (substr SearchStr (1+ n) StringLen))
    (setq StringLen (strlen SearchStr))
)
(reverse return)
)

;;; 反解析表为字符串
(defun StrUnParse (Lst Delimiter / return)
(setq return "")
(foreach str Lst
    (setq return (strcat return Delimiter str))
)
(substr return 2)
)

;;; 移除支持文件搜索路径
(defun QF_RemoveSupportPath (PathToRemove / supportlist)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(setq supportlist
(vl-remove-if
    '(lambda (x) (= (strcase x) (strcase PathToRemove)))
    supportlist
)
)
(setenv "ACAD" (strUnParse supportlist ";"))
)

;;; 添加支持文件搜索路径
;;; 第二个参数如果为真, 插最前，否则插最后
(defun AddSupportPath (PathToAdd isFirst / supportlist)
(QF_RemoveSupportPath PathToAdd)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(if isFirst
    (setq supportlist (cons PathToAdd supportlist))
    (setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
)

;;; 加载菜单
(defun load-xzh (/ n)
(if (not (menugroup "xzh"))
    (progn (setq n 1)
    (while (< n 24)
      (if (menucmd (strcat "P" (itoa n) ".1=?"))
      (setq n (+ n 1))
      (progn (if (> n 3)
   (setq n (- n 2))
   (setq n 3)
      )
      (command "menuload" "xzh")
      (menucmd (strcat "p" (itoa n) "=+xzh.pop12"))
                      (menucmd (strcat "p" (itoa n) "=+xzh.pop13"))
                      (menucmd (strcat "p" (itoa n) "=+xzh.pop14"))
                      (menucmd (strcat "p" (itoa n) "=+xzh.pop15"))
                      (menucmd (strcat "p" (itoa n) "=+xzh.pop16"))
      (setq n 25)
      )
      )
    )
    )
)
(princ)
)

;;; 初始化主函数
(defun Init_xzh ()
(if (not (menugroup "xzh")) ; 如果菜单组还没有被加载，则加载之
    (progn (AddSupportPath (GetmylyPath) nil) ; 添加支持路径
    (AddSupportPath (strcat (GetmylyPath) "\\dwg") nil)
    (AddSupportPath (strcat (GetmylyPath) "\\bmp") nil)
    (AddSupportPath (strcat (GetmylyPath) "\\xzh") nil)
    (load-xzh)
    )
)
(princ)
)

;;; 主程序：
(princ "\n工具箱1.0……")
(setq cmdecho_save (getvar "cmdecho"))
(setvar "cmdecho" 0)
;;; 执行初始化
(Init_xzh)
(setvar "cmdecho" cmdecho_save)
(setq cmdecho_save nil)
(princ "\n工具箱1.0。")
(princ)


加载au.lsp无法实现图一，图二，图三等图的添加文件支持路径，加载A.vlx xzh.vlx到启动组，同时在CAD菜单栏显示绘图A、
修编D、模具S 、标注W、 图层Q等菜单。请高手指点迷津，谢谢


wowan1314 发表于 2013-4-10 11:39:46

你要配套的使用秋枫的那个安装程序才可以的吧！？ 单独加载是不行的。
http://bbs.mjtd.com/thread-35151-1-1.html

sfzyr 发表于 2013-4-11 07:25:23

程序还是不错，先留个脚印，有空再看看

726613 发表于 2013-4-13 21:11:46

sfzyr 发表于 2013-4-11 07:25 static/image/common/back.gif
程序还是不错，先留个脚印，有空再看看

谢谢您来光顾

muwind 发表于 2020-6-20 23:08:25

wowan1314 发表于 2013-4-10 11:39
你要配套的使用秋枫的那个安装程序才可以的吧！？ 单独加载是不行的。
http://bbs.mjtd.com/thread-35151- ...

可以不用秋枫的那个安装程序，自己写注册表或者固定一个目录 比如 c:\xxx ，也就是不用GetPath (AppID) 获取支持文件夹，实现起来都不难，简单的找个vb程序都可以实现。
页: [1]
查看完整版本: CAD二次开发程序包