CAD二次开发程序包

726613

      图一

图二

图三

;;;部分代码转自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

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

sfzyr

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

726613

sfzyr 发表于 2013-4-11 07:25
程序还是不错，先留个脚印，有空再看看

谢谢您来光顾

muwind

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

可以不用  秋枫的那个安装程序，自己写注册表或者固定一个目录 比如 c:\xxx ，也就是不用GetPath (AppID) 获取支持文件夹，实现起来都不难，简单的找个vb程序都可以实现。