备忘语录

1、获取系统桌面路径

(strcat (vla-item (vlax-get (vlax-create-object "WScript.Shell" ) 'SpecialFolders) "Desktop") "\\")

2、lisp运行时间计算

(setq time0 (getvar "date")) ;;计时1
(setq leftDic(d-DelSame AA)) ;;字典法
(setq time1 (getvar "date")) ;;计时2
(setq leftRec(delsame AA))  ;;递归法
(setq time2 (getvar "date")) ;;计时3
(princ (strcat "\n字典方法耗时: " (rtos (* 86400 (- time1 time0)) 2 4) " 秒"))
(princ (strcat "\n递归方法耗时: " (rtos (* 86400 (- time2 time1)) 2 4) " 秒"))

3、获取系统时间 (DIESEL方式获取)

(menucmd "M=$(edtime,$(getvar,date), YYYY.M.D hh:mm:ss)")
(menucmd "M=$(edtime,$(getvar,date),DDD\", \"D MON YYYY)") ->"周三, 8 八月 2007"
(menucmd "M=$(edtime,$(getvar,date),YYYY.M.DD hh:mm:ss)") ->"2007.8.08 12:24:49"
(menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD HH:MM DDDD)") ->"2021.07.17 10:01 星期六"
(menucmd "M=$(edtime,$(getvar,date),YYYY\"年\"M\"月\"DD\"日\" hh\"时\"mm\"分\"ss\"秒\")") －> "2007年8月08日 12时26分06秒"
(defun c:mydate(/ date dimzin str )
  (setq date(getvar 'cdate))
  (setq dimzin(getvar 'dimzin))
  (setvar 'dimzin 0)
  (setq str(rtos date 2 6))
  (setvar 'dimzin dimzin)
  (list (substr str 1 4) (substr str 5 2)(substr str 7 2)(substr str 10 2) (substr str 12 2) (substr str 14 2))
)

DIESEL 函数参考

状态的检索、计算和显示均由 DIESEL 函数执行。
所有的函数最多只能包含 10 个参数，包括函数名本身。

如上表所示，应该输入完整的 AM/PM 短语。如果仅使用 AM，则 A 将按字面复制而 M 将返回当前月份。
如果图片中出现任何 AM/PM 短语，则 H 和 HH 短语将按 12 小时国内时钟 (12:00-12:59 1:00-11:59) 编辑时间，而不是按 24 小时时钟 (00:00-23:59) 编辑时间。
下面的样例使用上表中的日期和时间。请注意，由于逗号被读为参数分隔符，因此必须将它括在引号中。
$(edtime, $(getvar,date), DDD”,” DD MON YYYY - H:MMam/pm)
该表达式返回以下结果：
Sat, 5 Sep 1998 - 4:53am
如果 time 为 0，则使用执行最外层宏时的时间和日期。这避免了对 $(getvar,date) 的冗长而费时的多次调用，并保证所有由多个 $(edtime) 宏组成的字符串都使用相同的时间。 | | eq | 如果字符串 val1 和 val2 相同，则字符串返回 1；否则，返回 0。
$(eq, val1, val2)
以下表达式用于获取当前图层的名称；如果该名称与 USERS1 (USERS1-5) 系统变量中存储的字符串值相匹配，则将返回 1。假设字符串“PART12”存储在 USERS1 中，并且当前图层相同。
注： USERS1-5 系统变量在 AutoCAD LT 中不可用。
$(eq, $(getvar, users1), $(getvar, clayer))
该表达式返回以下结果：
1 | | Eval | 将字符串 str 传给 DIESEL 计算器，并返回计算结果。
$(eval, str) | | fix | 通过舍弃小数部分，将实数数字 值 截断为整数。
$(fix, value) | | Getenv | 返回环境变量 varname 的值。
$(getenv, varname)
如果未定义具有该名称的变量，则返回空字符串。 | | Getvar | 返回具有给定 varname 的系统变量的值。
$(getvar, varname) | | if | 根据条件计算表达式。
$(if, expr, dotrue [, dofalse])
如果 expr 为非零，则进行计算并返回 dotrue 。否则，进行计算并返回 dofalse 。请注意，不计算 expr 未选择的分支。 | | 索引颜色 | 返回以逗号分隔的字符串中的指定成员。
$(index, which, string)
假定 string 参数包含一个或多个由宏参数分隔符字符（逗号）分隔的值。 which 参数选择这些值中的一个值进行提取，第一项编号为 0。此函数通常用于从 $(getvar) 返回的点坐标中提取 X、Y 或 Z 坐标值。
使用此函数，应用程序可从 USERS1-5 系统变量中检索存储为以逗号分隔的字符串的值。
注： USERS1-5 系统变量在 AutoCAD LT 中不可用。 | | nth | 计算并返回由 which 选定的参数。
$(nth, which, arg0 [, arg1,…, arg7])
如果 which 为 0，则 nth 返回 arg0 ，依此类推。请注意， $(nth) 和 $(index) 之间的区别； $(nth) 将一系列参数中的一个返回给函数，而 $(index) 从作为单个参数传递的以逗号分隔的字符串中提取值。不计算 which 未选择的参数。 | | 或 | 返回整数 val1 到 val9 的按位逻辑或。
$(or, val1 [, val2,…, val9]) | | Rtos | 按指定的格式和精度返回实数值。
$(rtos, value [, mode, precision])
将给定的 值 作为实数进行编辑，按照下面两个变量指定的格式： mode 和 precision。 如果省略 mode 和 precision ，则使用由 UNITS 命令选择的当前值。 | | strlen | 返回 string 的字符长度。
$(strlen, string) | | Substr | 返回 string 的子串，该子串从字符 start 开始，长度为 length 。
$(substr, string, start [, length])
字符串中的字符从 1 开始编号。如果省略 length ，则返回所有剩余字符串。 | | 上 | 返回 string 按当前地区的规则转换为大写的结果。
$(upper, string) | | xor | 返回整数 val1 到 val9 的按位逻辑异或。
$(xor, val1 [, val2,…, val9]) |

4、限定整数输入，其他限定类似

(setq initgetlst '(1 2 3 4 5))
(while (not(member (setq getinputNum (getint "\n输入选项[1/2/3/4/5]: ")) initgetlst))
    (princ "\n请输入规定的整数值")
)

5、Lisp创建文件夹

(vl-mkdir "d:\\ab")               ; 在D盘建立ab文件夹
;lisp创建文件夹
;方法一
(defun CreateFolder (s / fso )
  (setq fso (vlax-create-object "Scripting.FileSystemObject"))
  (vlax-invoke-method fso 'CreateFolder s)
  (vlax-release-object fso)
)
(createfolder "C:\\Users\\Admin\\Desktop\\26456")
;方法二
(and (not (findfile "c:\\mydirectory")) (vl-mkdir "C:\\Users\\Admin\\Desktop\\46946"))

6、简单读写文件

(if (findfile (vl-filename-directory (setq path "D:\\我的插件-懒猪\\seting.ini")))
    (if (and (findfile path) (/= (setq str (vl-string-trim " " (read-line (setq file (open path "r"))))) ""))
        (progn
            (setq seting (read str))
            (close file)
        )
    )
    (vl-mkdir (vl-filename-directory path))
)
(defun putseting(lst / file)
    (setq file (open "D:\\我的插件-懒猪\\seting.ini" "w"))
    (write-line (vl-prin1-to-string lst) file)
    (close file)
)

7、取得多段线顶点表的最短代码

(defun getptlst (en)
   (mapcar 'cdr (vl-remove-if ''((x) (/= 10 (car x))) (entget en)))
)

8、复制文件到另一个目录

(setq fso (vlax-create-object "Scripting.FileSystemObject"))
(vlax-invoke fso "CopyFile" flpath (getvar "dwgprefix"))

（参考 https://blog.csdn.net/yxp_xa/article/details/73158988）

9、文件类型过滤方法

;;;----------------------------------------------------;
;;;功能: 获得选择的文件列表                          ;
;;;输入: msg 提示 如："请选择文件:"  filetype "文件类型" fileextension 文件后缀名列表;
;;;输出: 文件路径列表                                 ;
;;;说明: 2017 10.09                                   ;
;;;示例(setq aa2 (getfiles "选择文件："  "jpg" '( ".jpg" ".png" ".bmp") ));
(defun getfiles(msg filetype fileextension /  path pf  file)
    (setq lastfolder (getvar "Dwgprefix"))
    (setq pf (getfiled msg (strcat "" lastfolder  "") filetype   0))
    (setq path (vl-filename-directory pf))
    (setq imglist (vl-directory-files path "*" ))
    (setq imglist(vl-remove "." imglist))
    (setq imglist(vl-remove ".." imglist))
    (setq imglist(vl-sort imglist '>) )
    (foreach x imglist
        (if (member (vl-filename-extension  x)   fileextension )
            (setq  file (cons (strcat path "\\" x ) file))
        )
    )
    file
)
;'文件过滤方法exp "mp4文件;avi文件;wmv文件|*.mp4;*.avi;*.wmv"
;(DCLGETFILES "*|*.jpg|*.png|*.bmp|" )
;(dclgetfiles "图片|*.jpg;*.png;*.bmp" )
(defun dclgetfiles(filters / file_list getdocs)
    (if (not dcl_SelectFiles)
        (command "opendcl")
  )
    (setq file_list (dcl_SelectFiles  filters ; Filters
                                        "选择文件" ; Title
                                        (if g:lastfolder
                                            g:lastfolder
                                            (getvar "DWGPREFIX")
                                        ) 
                                    )
  )
  (if file_list  
    (progn
      (setq g:lastfolder (vl-filename-directory (car file_list)))
    )
  )
  file_list
)

10、使用通配符搜索匿名块时，通配符要进行转义，使用脱字符`进行转义后方可通配！

11、获取CAD的安装路径

(Vla-Get-Path (Vlax-Get-Acad-Object))

12、Odcl向CAD发送命令，下次空格或回车有效

(dcl-SendString "abc ")

13、获取句柄，通过句柄获取图元名

(setq handle (cdr (assoc 5 (entget (car (entsel))))))
(handent handle)

14、获取系统时间并报时

(defun c:times ()
    (setq time (substr (rtos (getvar "cdate") 2 12) 10 4))
    (setq hh (itoa(atoi (substr time 1 2))))
    (setq mm (itoa(atoi (substr time 3 2))))
    (setq time(strcat "现在时间" hh "点" mm "分"))
    (vlax-invoke-method (vlax-create-object "Sapi.SpVoice") "Speak" time 0)
)

15、vlisp过滤选择；vlsp选择、亮显obj选择集和取消亮显

(vla-highlight newSet 1)
(vla-highlight newSet 0)

全选为object对象

;;说明:全选为object对象
(defun c:al-select()
    (vl-load-com)
    (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
    (setq ssets (vla-get-selectionsets thisdrawing))
    (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list ssets "$Set")))
        (setq newSet (vla-add ssets "$Set"))
        (progn
            (vla-delete (vla-item ssets "$Set"))
            (setq newSet (vla-add ssets "$Set"))
        );progn
    );if
    (vla-Select newSet acSelectionSetAll)
    (vla-Highlight newSet 1)
);defun

过滤选择

;;说明:过滤选择
;;参数:lst:过滤表
;;'((0 . "INSERT0") (1 . "INSERT1") (2 . "INSERT2") (3 . "INSERT3") (4 . "INSERT4"))
(defun al-selectonscreen(lst / dxflst filter_code filter_value newset ssets thisdrawing)
    (vl-load-com)
    (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
    (setq ssets (vla-get-selectionsets thisdrawing))
    (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list ssets "SS1")))
        (setq newSet (vla-add ssets "SS1"))
        (progn
            (vla-delete (vla-item ssets "SS1"))
            (setq newSet (vla-add ssets "SS1"))
        )
    )
    (setq dxflst (list (mapcar 'car lst) (mapcar 'cdr lst)))
    (setq filter_code (vlax-make-safearray vlax-vbinteger (cons 0 (- (length (car dxflst)) 1))))
    (setq filter_value (vlax-make-safearray vlax-vbvariant (cons 0  (- (length (cadr dxflst)) 1))))
    (vlax-safearray-fill filter_code (car dxflst))
    (vlax-safearray-fill filter_value (cadr dxflst))
    (vla-selectOnScreen newSet filter_code filter_value)
    newSet
)

点选图元为object对象

;;说明:点选图元为object对象
;;参数:opstr:提示
;;返回:选中则返回图元object对象，否则返回nil
(defun al-selectatpoint (opstr / util)
    (vl-load-com)
    (setq util (vla-get-utility (vla-get-activedocument (vlax-get-acad-object))))       
    (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-getentity (list util 'obj 'ip opstr)))
        nil
        (progn
            ;(vla-Highlight obj 1)
            obj
        )
    )
)

16、获取文字长度

;;说明:获取文字长度
;;参数:e:图元名
;;返回:文字长度   (BF-ent-textlen (car (entsel)))
(defun BF-ent-textlen (e / bf-str->lst data lenlst lst)
    (defun BF-str->lst    (str del / pos)
        (if    (setq pos (vl-string-search del str))
            (cons (substr str 1 pos)
                (BF-str->lst (substr str (+ pos 1 (strlen del))) del)
            )
            (list str)
        )
    )
    (cond
        ((= (cdr (assoc 0 (setq data (entget e)))) "TEXT") 
            (car (apply 'mapcar (cons '- (reverse (textbox (entget e))))))
        )
        ((= (cdr (assoc 0 data)) "MTEXT")
            (setq lst (BF-str->lst (cdr (assoc 1 data)) "\\P"))
            (foreach str lst
                (if (/= str "")
                    (setq lenlst (cons (car (apply 'mapcar (cons '- (reverse (textbox (list (cons 0 "text") (assoc 40 data) (cons 1 str) (assoc 7 data))))))) lenlst))
                )
            )
            (apply 'max lenlst)
        )
    )
)

17、图元的最小包围盒

;;;name:BF-ent-getbox
;;;desc:图元的最小包围盒
;;;arg:ent:图元名
;;;arg:offset:外框偏移距离
;;;等于0 / nil，不偏移
;;;大于0，向外偏移
;;;小于0，向内偏移
;;;return:外框（偏移后）的左下，右上角点
;;;example:(BF-ent-getbox (car(entsel)) 0.1)
(defun BF-ent-getbox (ent offset / bf-list- bf-list+ lst obj p1 p2 p3 p4)
    (defun BF-list+    (lst1 lst2) (mapcar '+ lst1 lst2))
    (defun BF-list-    (lst1 lst2) (mapcar '- lst1 lst2))
  (setq obj (vlax-ename->vla-object ent))
  (vla-GetBoundingBox obj 'p1 'p3)
  (setq    p1 (vlax-safearray->list p1)
        p3 (vlax-safearray->list p3)
  )
  (if (= "SPLINE" (cdr (assoc 0 (entget ent))))
    (progn
      (setq lst
                (mapcar
                    '(lambda    (a b)
                         (vlax-curve-getClosestPointToProjection ent a b t)
                     )
                    (list p1
                        (list (car p1) (cadr p3) (caddr p1))
                        p3
                        (list (car p3) (cadr p1) (caddr p1))
                    )
                    '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
                )
      )
      (setq
                p1 (apply 'mapcar (cons 'min lst))
                p3 (apply 'mapcar (cons 'max lst))
      )
    )
  )
  (if (or (not offset) (equal offset 0 0.0001))
    (list p1 p3)
    (list
      (BF-list- p1 (list offset offset 0))
      (BF-list+ p3 (list offset offset 0))
    )
  )
)
;;与文字平行
(defun getTextBox (en / b enx h j l n o r w)
    (cond
        ((= 'VLA-OBJECT (type en)) (setq enx (entget (vlax-vla-object->ename en))))    
        ((= 'ename (type en)) (setq enx (entget en)))    
        ((= 'list (type en)) (setq enx en))
    )  
    (setq l 
        (cond
            ((= "TEXT" (cdr (assoc 0 enx)))
                (setq
                    b (cdr (assoc 10 enx))
                    r (cdr (assoc 50 enx))    
                    l (textbox enx)      
                    n (cdr (assoc 210 enx))    
                )
                (list
                    (list (caar l) (cadar l))    
                    (list (caadr l) (cadar l))
                    (list (caadr l) (cadadr l))
                    (list (caar l) (cadadr l))
                )
            )
            ((= "MTEXT" (cdr (assoc 0 enx)))
                (setq
                    n (cdr (assoc 210 enx))
                    b (trans (cdr (assoc 10 enx)) 0 n)
                    r (angle '(0.0 0.0 0.0) (trans (cdr (assoc 11 enx)) 0 n))
                    w (cdr (assoc 42 enx))
                    h (cdr (assoc 43 enx))
                    j (cdr (assoc 71 enx))
                    o (list
                            (cond
                                ((member j '(2 5 8)) (/ w -2.0))
                                ((member j '(3 6 9)) (- w))
                                (0.0)
                            )
                            (cond
                                ((member j '(1 2 3)) (- h))
                                ((member j '(4 5 6)) (/ h -2.0))
                                (0.0)
                            )
                        )
                )
                (list
                    (list (car o) (cadr o))
                    (list (+ (car o) w) (cadr o))
                    (list (+ (car o) w) (+ (cadr o) h))
                    (list (car o) (+ (cadr o) h))
                )
            )
        )
    )
    (setq l 
        (
            (lambda (m)
                (mapcar
                    '(lambda (p)
                         (mapcar '+(mapcar '(lambda (r) (apply '+ (mapcar '* r p))) m) b)
                     )
                    l
                )
            )
            (list
                (list (cos r) (sin (- r)) 0.0)
                (list (sin r) (cos r) 0.0)
                '(0.0 0.0 1.0)
            )
        )
    )
    (mapcar '(lambda (x) (trans x n 0)) l)
)

18、lisp读取excel单元格

Vlax-Get (vlax-variant-value (vlax-get-property cells "item" 2 8)) 'Formula)

19、获取图元扩展属性

(ENTGET (CAR (ENTSEL)) '("*"))

20、获取网络时间（大海版）

;;用get方式读取网页信息
;;返回页面文本字符串
;;连接不上返回nil
(defun try-get-url(url / ob html)
    (setq ob (vlax-create-object "Msxml2.XMLHTTP"))
    (vlax-invoke-method ob "open" "get" url "false")
    (vlax-invoke-method ob 'setRequestHeader "If-Modified-Since" "q");强制刷新
    (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke-method (list ob "send")))
        (setq html nil);无网络连接
        (setq html (vlax-get-property ob "responseText"))
    )
    (vlax-release-object ob)
    html
)
;;由给定的日期返回儒略日期(公元前4713)
;;(try-Date2Value 2016 4 11)
(defun try-Date2Value (Year Month Day / a_date b_date c_date e_date f_date juliandate)
    (if (< Month 3)(setq Year(1- Year)Month(+ 12 Month)))
    (setq
        a_date (fix(/ Year 100.))
        b_date (fix(/ a_date 4.));每4年1461天
        c_date (- 2.0 (- a_date b_date))
        e_date (fix(/ (* 1461. (+ Year 4716.0)) 4));多少个4年
        f_date (fix(/ (* 153. (1+ Month)) 5.))
        JulianDate (fix(+ c_date Day e_date f_date (- 1524)))
    )
)
;;由儒略日期返回普通日期
;;(try-Value2Date 2457490);> '(25016 4 11)
(defun try-Value2Date (Value / _af _bf _cf _df _ef _ff _wf _xf _zf day month return year)
    (if (> Value 0)
        (setq 
            _zF (fix Value)
            _wF (fix(/ (- _zF 1867216.25) 36524.25))
            _xF (fix(/ _wF 4.))
            _aF (+ _zF 1 _wF (- _xF))
            _bF (+ _aF 1524.)
            _cF (fix(/ (- _bF 122.1) 365.25))
            _dF (fix(* 365.25 _cF))
            _eF (fix(/ (- _bF _dF) 30.6001))
            _fF (fix(* 30.6001 _eF))
            Day (- _bF _dF _fF)
            Month (if (< (1- _eF)13)(1- _eF)(- _eF 13))
            Year (if(< Month 3)(- _cF 4715)(- _cF 4716))
            Return (list (fix Year)(fix Month)(fix Day))
        )
    )
)
;;将时间戳(毫秒|实数)转换为北京时间
;;返回(0年 1月 2日 3时 4分 5秒 6毫秒)
(defun try-time-stamp2beijing (time / a b h hf hm mm mmf s sf y-m-d)
    (setq
        a(+ time 210866832000000.0);加上格林威治时间+8小时(毫秒)
        b(fix(/ a 86400000));返回儒略天数
        y-m-d(try-Value2Date b)
        h(/(- a (* b 86400000.0))3600000.0)
        hf(fix h)
        mm(*(- h hf)60)
        mmf(fix mm)
        s(*(- mm mmf)60)
        sf(fix s)
        hm(fix(*(- s sf)1000))
    )
    (append y-m-d (list hf mmf sf hm))    
)
;;获取网络时间，接口为京东时间接口
;;返回(0年 1月 2日 3时 4分 5秒 6毫秒)
(defun try-time-getbeijing (/ time)
    (setq time(substr(try-get-url "https://api.m.jd.com/client.action?functionId=queryMaterialProducts&client=wh5")54 13)
        time(atof time)
    )
    (try-time-stamp2beijing time)
)
(try-time-getbeijing)

21、计算随机数

;;;name:SWH-Math-Rand
;;;desc:计算随机数，leemac
;;;arg:
;;;return:0-1之间的随机数
;;;example:(SWH-Math-Rand)
(defun SWH-Math-Rand (/ a c m)
  (setq    
        m   4294967296.0
        a   1664525.0
        c   1013904223.0
        $xn (rem (+ c
                             (* a
                                 (cond ($xn)
                                     ((getvar 'date))
                                 )
                             )
                         )
                    m
                )
  )
  (/ $xn m)
)
(repeat 50 (print (BF-math-Rand1 0 100 nil)))
;获取变量值，low=最小值，upper=最大值，idx=是否截去值的小数部分，T截去，非T不截去
(defun BF-math-Rand1 (low upper idx / num)
  (setq num (+ low (* upper (/ (rem (getvar "CPUTICKS") 1984.0) 1983.0))))
    (if idx
        (setq num (fix num))
    )
    num
)

(defun random(site / date rdm);site作为随机数位数，定义为1，2，3分别对应0-9，0-99，0-999
    (if (<= 1 site 3)
        (progn
            (setq date (* 100000000 (getvar "cdate")));获取当前时间并去掉小数点赋值到date
            (setq remValue 1);赋值除数为1
            (repeat site
                (setq remValue(* 10 remValue))
            );循环次数等于保留位数，如果三次则remValue等于1000，两次100，一次10
            (setq rdm (rem date remValue));将date保留最后若干位，赋值到rdm
        )
    )
);如果site大于3或小于3则函数停止
(random 1)
(rtos (getvar "cdate") 2 16)
(defun lsp201510261 ( / n3 n4)
 (setq n3 (rtos (rem (getvar "Date") 1) 2 20))
 (setq n3 (substr n3 18 1) n3 (atoi n3))
 (setq n4 (rem (getvar "CPUTICKS") 10))
 (fix (rem (+ n3 n4) 10))
)
;获取变量值，low=最小值，upper=最大值，idx=是否截去值的小数部分，T截去，非T不截去
(defun BF-math-Rand1 (low upper idx / num)
  (setq num (+ low (* upper (/ (rem (getvar "CPUTICKS") 1984.0) 1983.0))))
    (if idx
        (setq num(fix num))
    )
    num
)
;;;name:SWH-Math-Rand
;;;desc:计算随机数，leemac
;;;arg:
;;;return:0-1之间的随机数
;;;example:(SWH-Math-Rand)
(defun SWH-Math-Rand (/ a c m)
  (setq    
        m   4294967296.0
        a   1664525.0
        c   1013904223.0
        $xn (rem (+ c
                             (* a
                                 (cond ($xn)
                                     ((getvar 'date))
                                 )
                             )
                         )
                    m
                )
  )
  (/ $xn m)
)

22、利用gbenor.shx gbcbig.shx消除当前活动文档字体乱码

;;;name:BF-Ent-Check-Error-Codes
;;;desc:消除字体乱码，利用gbenor.shx gbcbig.shx
;;;arg:doc:当前活动文档
;;;return:无
;;;example:(BF-Ent-Check-Error-Codes (BF-active-document))
(defun BF-Ent-Check-Error-Codes(doc)
  (vlax-for txtstyle (vla-get-textstyles doc)
    (if    (findfile (vla-get-fontfile txtstyle))
      nil
      (vla-put-fontfile txtstyle "gbenor.shx")
    )
    (if    (findfile (vla-get-bigfontfile txtstyle))
      nil
      (vla-put-bigfontfile txtstyle "gbcbig.shx")
    )
  )
  (princ)
)
(BF-Ent-Check-Error-Codes (vla-get-activedocument (vlax-get-acad-object)))

23、Explorer.exe的命令行参数

;Explorer.exe的命令行参数http://www.cnblogs.com/ymind/archive/2012/03/30/explorer-command-args.html
;
;摘要
;本文讲述explorer.exe（资源管理器）的命令行。
;
;语法
;EXPLORER.EXE [/n][/e][,/root,<object>][[,/select],<sub object>]
;
;/n: 默认选项，用我的电脑视图为每个选中的item打开一个单独的窗口,  即使该窗口已经被打开。
;
;/e: 使用资源管理器视图。资源管理器视图和Windows 3.x的文件管理器非常相似。
;
;/root,<object>: 指定视图目录根，默认使用桌面作为根目录。
;
;/select,<sub object>: 选中指定对象。如果使用"/select" , 则父目录被打开，并选中指定对象。
;
;例子
;打开资源管理器视图并以C:\Windows为目录根浏览
;
;explorer /e,/root,C:\Windows
;
;打开资源管理器视图并选中Calc.exe
;
;explorer /e,/select,c:\windows\system32\calc.exe
;
;注意：/root和/select最好不要同时使用。

24、1+2+3

(defun c:ii()
    (setq n 0 a n WZ "0")
    (while (<= n 10) (if (<= n 10) (setq WZ (strcat WZ "+" (rtos (setq n (+ n 1))))) (setq n (+ n 1))))
    (command "TEXT" (getpoint "请指定文字位置：") "" "" WZ)
)

25、显示标准的 AutoCAD 颜色选择对话框

(acad_colordlg colornum [flag])

参数
colornum
整数，其取值范围是 0-256 （包括 0 和 256），它用于指定颜色对话框的缺省的颜色代码。
flag
如可选参数 flag 设为 nil，禁用“随层”和“随块”按钮；省略 flag 参数或将其设为非 nil 值，则可启用“随层”和“随块”按钮。

colornum 为 0 时代表 BYBLOCK（随块），为 256 时代表 BYLAYER（随层）。
返回值
用户所选择的颜色代码，如果用户取消该对话框则返回 nil。
示例
下列代码提示用户选择一种颜色，如果不选则指定绿色为缺省颜色：
(acad_colordlg 3)

26、判断矩形是横向还是纵向

判断两点连线角度是靠近x轴还是y轴，不就知道横纵向了，或者分开求x坐标跟y坐标的差值，都可以得出

(setq p1 (getpoint) p2 (getcorner p1))
(if(> (apply '- (mapcar 'abs (mapcar '- p1 p2))) 0) "横向" "纵向")

27、捕捉设置

(Defun OSmode (Value)
  (if Value
    (Setvar "osmode" (rem (Getvar "osmode") 16384))
    (Setvar "osmode" (+ (rem (Getvar "osmode") 16384) 16384))
  )
)
(OSmode t)  ;开
(OSmode nil);关

28、获取多段线点表

(defun getptlst(e) (mapcar 'cdr (vl-remove-if-not (function (lambda(x) (= 10 (car x)))) (entget e))))

29、网页上跳转直接添加QQ好友、加入QQ群

(VL-CMDF "BROWSER" "tencent://message/?uin=871425525&Site=&Menu=yes")

添加QQ好友

<a href="tencent://message/?uin=757453794&Site=&Menu=yes" target="_blank" title="点击添加服主好友">服主QQ:757453794</a>

uin=后直接跟QQ号即可。

添加QQ群

<a href="https://jq.qq.com/?_wv=1027&k=51ukmBo" target="_blank" title="点击加入玩家交流群">QQ群:618967676</a>

QQ群的参数来源：在群的主页有个群应用——>群分享——> 由此获得群链接。

30、ssget多项排除

(setq ss (ssget '((0 . "line")(-4 . "<not") (8 . "0,1") (-4 . "not>"))))

31、正交切换

(defun C:vv () (setvar "OrthoMode" (boole 6 (getvar "OrthoMode") 1)))

32、图元类型判断

(setq entpy (strcase (cdr (assoc 0 (if (= (cdr (assoc 102 (setq edata (entget (car (entsel)))))) "{ACAD_REACTORS") (entget (cdr (assoc 330 edata))) edata)))))
(cond 
    ((equal entpy "LINE")
        (alert "直线")
    )
    ((equal entpy "INSERT")
        (alert "块")
    )
    ((equal entpy "GROUP")
        (alert "群组")
    )
)

33、群组增加物体，群组减物体，炸特定组，全图删除组，点选显示组名

;;创建组
(defun c:ga(/ ss)
  (setvar "PICKSTYLE" 1)
  (setvar "cmdecho" 0)
  (if (setq ss (ssget))
    (repeat (setq i (sslength s))
      (setq e (ssname s (setq i (1- i))))
      (if (= "GROUP" (cdr (assoc 0 (entget (setq g (cdr (assoc 330 (entget e))))))))(entdel g))
    )
  )
  (command "-group" "" "*" "" ss "")
  (setvar "cmdecho" 1)
  (princ "\n选定对象已经组合。")
  (princ)
)
;;;组减物体
(defun c:ge ()
  (if (setq EntName1 (car (entsel "\n选择组: ")))
    (progn
      (setq EntList (entget EntName1))
      (if (= (cdr (assoc 102 EntList)) "{ACAD_REACTORS")
        (progn
          (setq Group (cdr (assoc 330 EntList)))
          (setq EntList (entget Group))
          (setq Dictionary (cdr (assoc 330 EntList)))
          (setq EntList (entget Dictionary))
          (setq Previous "")
          (foreach Item EntList
            (setq Item (cdr Item))
            (if (equal Item Group)
              (setq GroupName1 Previous)
            );if
            (setq Previous Item)
          );foreach
          (command "-group" "r" groupname1 pause )
        );progn
        (princ "\n选择的物体不是组中的成员.")
      );if
    );progn
    (princ "\n没有选中物体.")
  )
)
;;炸特定组
(defun c:gx ()
  (if (setq s (ssget))
    (repeat (setq i (sslength s))
      (setq e (ssname s (setq i (1- i))))
      (if (= "GROUP" (cdr (assoc 0 (entget (setq g (cdr (assoc 330 (entget e))))))))(entdel g))
    )
  )
)
;;全图删除组
(defun c:gxx ()
   (C:DelEmptyGroup)
   (C:DelAllGroups)
   (setvar "PICKSTYLE" 0)
   (princ)
)
;;删除所有组_函数
(defun c:DelAllGroups ()
  (or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
  (or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
  (vlax-for obj        (vla-get-groups *DOC*)
    (vla-delete obj)
  )
)
;;删除空组_函数
(defun c:DelEmptyGroup  ()
  (or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
  (or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
  (vlax-for obj        (vla-get-groups *DOC*)
    (if        (< (vla-get-count obj) 2)
      (vla-delete obj)
    )
  )
)
;;;显示组名
(defun c:gn ()
  (if (setq EntName (car (entsel "\n选择组: ")))
    (progn
      (setq EntList (entget EntName))
      (if (= (cdr (assoc 102 EntList)) "{ACAD_REACTORS")
        (progn
          (setq Group (cdr (assoc 330 EntList)))
          (setq EntList (entget Group))
          (setq Dictionary (cdr (assoc 330 EntList)))
          (setq EntList (entget Dictionary))
          (setq Previous "")
          (foreach Item EntList
            (setq Item (cdr Item))
            (if (equal Item Group)
              (setq GroupName Previous)
            );if
            (setq Previous Item)
          );foreach
                    (princ (strcat "\n组名为 " GroupName " ."))
        );progn
        (princ "\n选择的物体不是组中的成员.")
      );if
    );progn
    (princ "\n没有选中物体.")
  )
)

34、AutoCAD.Net系统变量设置

Application.SetSystemVariable("ORTHOMODE", 1);  //正交开

35、使用CAD图标

ZwSoft.ZwCAD.ApplicationServices.Application.ShowModelessDialog(Frm);

36、CAD设置图元颜色

Variable: $CECOLOR
Group Code: 62
Description: Current entity color number:
0 = BYBLOCK;
256 = BYLAYER
Type: String
if your are using CECOLOR, try:
(setvar "CECOLOR" "256")
It will also take the color names for 1-7 as well as 'BYBLOCK" & "BYLAYER"
(setvar "CECOLOR" "WHITE")
more info:
https://forums.autodesk.com/t5/autocad-forum/how-to-make-current-color-in-color-contro-the-same-as-the-color/m-p/5396871#M65777

37、返回【CAD所在路径】和【当前dll文件路径】

//返回CAD所在路径
string str = AppDomain.CurrentDomain.BaseDirectory;
//返回当前dll文件路径
string bbb = Path.GetDirectoryName(Assembly.GetExecutingAssembly().Location);

38、取得选择集内不重叠的外矩形框（还不是准确）

;|= 4.2.2 取得选择集内不重叠的外矩形框
@== (wyb-get-mBox ss)
#== return: [lst]'((p1 p2) (p3 p4) ... )
ver:
[1.0] 明经Gu_xl&邹锋
[1.1] by woyb 20151007
[1.1.1] 修复ss为单个对象时无法处理的bug by woyb 20151010
====================|;
(defun wyb-get-mBox (@ss / _intersect n l a l1 flag b c lst)
    (defun _intersect (a b)
        (if
            (or
                (and ;;b左下角在a框内
                    (<= (caar a) (caar b) (caadr a))
                    (<= (cadar a) (cadar b) (cadadr a))
                )
                (and ;;b左上角在a框内
                    (<= (caar a) (caar b) (caadr a))
                    (<= (cadar a) (cadadr b) (cadadr a))
                )
                (and ;;b右上角在a框内
                    (<= (caar a) (caadr b) (caadr a))
                    (<= (cadar a) (cadadr b) (cadadr a))
                )
                (and ;;b右下角在a框内
                    (<= (caar a) (caadr b) (caadr a))
                    (<= (cadar a) (cadar b) (cadadr a))
                )
                (and ;;a框部分包含在b框内
                    (<= (caar a) (caar b) (caadr a)) ;;xa1<=xb1<=xa2
                    (>= (cadar a) (cadar b)) ;;ya1>=yb1
                    (<= (cadadr a) (cadadr b)) ;;ya2<=yb2
                )
            )
            (list
                (apply 'mapcar (cons 'min (append a b)))
                (apply 'mapcar (cons 'max (append a b)))
            )
        )
    )
    ;|= 4.2. 取得图元外矩形框
    @== (wyb-get-box ename)
    #== return: [plst]'((x1 y1 z1)_min (x2 y2 z2)_max)
    ver: 
    [1.0] 明经 Longxin, Gu_xl&邹锋
    [1.1] by woyb 20151010
    [1.1.1] ADD: 释放obj by woyb 20180730
    ====================|;
    (defun wyb-get-box (@e / p1 p2 p3 p4 obj lst tmp)
    (setq obj (vlax-ename->vla-object @e))
    (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'p1 'p3))))
            (progn
                (setq p1 (vlax-safearray->list p1)
                    p3 (vlax-safearray->list p3)
                    p2 (list (car p1) (cadr p3) (caddr p1))
                    p4 (list (car p3) (cadr p1) (caddr p1))
                )
                (if (= "SPLINE" (cdr (assoc 0 (entget @e))))
                    (progn
                        (setq lst
                            (mapcar '(lambda  (a b) (vlax-curve-getClosestPointToProjection @e a b t))
                                (list p1 p2 p3 p4)
                                '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
                            )
                        )
                        (setq tmp 
                            (list
                                (apply 'mapcar (cons 'min lst))
                                (apply 'mapcar (cons 'max lst))
                            )
                        )
                    )
                    (setq tmp (list p1 p3))
                )
            )
            (setq tmp nil)
    )
    (vlax-release-object obj)
    tmp
    )
    (setq lst '())
    (if @ss
        (progn
            (repeat (setq n (sslength @ss))
                (if (setq a (wyb-Get-Box (ssname @ss (setq n (1- n)))))
                    (setq l (cons a l))
                )
            )
            (setq l
                (vl-sort
                    l
                    '(lambda (a b)
                         (setq a '((1 11) (2 22))
                             b '((3 33) (4 44)))
                         x1       x3
                         (if (equal (caar a) (caar b) 1e-3)
                             (if (equal (cadar a) (cadar b) 1e-3)
                                 (if (equal (caadr a) (caadr b) 1e-3)
                                     (< (cadadr a) (cadadr b))
                                     (< (caadr a) (caadr b))
                                 )
                                 (< (cadar a) (cadar b))
                             )
                             (< (caar a) (caar b))
                         )
                     )
                )
            )
            (setq a (car l))
            (if (setq l (cdr l))
                (while l
                    (setq l1 nil flag nil)
                    (while l
                        (setq b (car l) l (cdr l))
                        (if (setq c (_intersect a b))
                            (setq a c flag t)
                            (setq l1 (cons b l1))
                        )
                    )
                    (setq l (reverse l1))
                    (if (not flag)
                        (progn
                            (setq lst (cons (list (car a) (cadr a)) lst))
                            (setq a (car l) l (cdr l))
                        )
                    )
                    (if (not l)
                        (setq lst (cons (list (car a) (cadr a)) lst))
                    )
                )
                (setq lst (cons (list (car a) (cadr a)) lst))
            )
        )
    )
    lst
)
(progn
    (setq time0 (getvar "date")) ;;计时1
    (foreach X (wyb-get-mBox (SSGET)) (entmake (LIST '(0 . "LINE") '(62 . 1) (CONS 10 (CAR X)) (CONS 11 (CADR X)))))
    (setq time1 (getvar "date")) ;;计时2
    (princ (strcat "\n字典方法耗时: " (rtos (* 86400 (- time1 time0)) 2 4) " 秒"))
)

39、更改CAD背景颜色

(defun c:gr(/ blue clno colvalue display green red rev-colour var-colour)
    (setq clno (getint "\n输入颜色号[黑(0)/红(1)/黄(2)/绿(3)/青(4)/蓝(5)/紫(6)/白(7)/灰(8)/灰白(9)]其他为黑色："))
  (cond
        ((= clno 1) (setq red 255 green 0 blue 0))
        ((= clno 2) (setq red 255 green 255 blue 0))
        ((= clno 3) (setq red 0 green 255 blue 0))
        ((= clno 4) (setq red 0 green 255 blue 255))
        ((= clno 5) (setq red 0 green 0 blue 255))
        ((= clno 6) (setq red 255 green 0 blue 255))
        ((= clno 7) (setq red 255 green 255 blue 255))
        ((= clno 8) (setq red 128 green 128 blue 128))
        ((= clno 9) (setq red 192 green 192 blue 192))
        (t (setq red 0 green 0 blue 0))
  )
  (setq
        colvalue (+ red (* green 256) (* blue 65536))
        var-colour (vlax-make-variant colvalue 19)
        rev-colour (if (= clno 8) (vlax-make-variant 16777215 19) (vlax-make-variant (- 16777215 colvalue) 19)) 
    display (vla-get-display (vla-get-preferences (vla-get-application (vlax-get-acad-object))))
  )
    (vla-put-graphicswinmodelbackgrndcolor display var-colour)
    (vla-put-ModelCrosshairColor display rev-colour)
  (vla-put-graphicswinlayoutbackgrndcolor display var-colour)
    (vla-put-LayoutCrosshairColor display rev-colour)
    (prin1)
)
(defun Backgroundcolor(Modelcol Layoutcol / layout model obtaincolvar prefdisplay);模型与布局背景颜色切换
    (vl-load-com)
    (defun obtainColVar(color / cindex colvar)
        (cond
            ((or (= 'INT (type color)) (= 'REAL (type color)))
                (setq cindex (fix color))  
                (cond
                    ((= 1 cindex) (setq colvar (vlax-make-variant 255 19) crocol (vlax-make-variant 16777215 19)))
                    ((= 2 cindex) (setq colvar (vlax-make-variant 65535 19) crocol (vlax-make-variant 0 19)))
                    ((= 3 cindex) (setq colvar (vlax-make-variant 65280 19) crocol (vlax-make-variant 0 19)))
                    ((= 4 cindex) (setq colvar (vlax-make-variant 16776960 19) crocol (vlax-make-variant 0 19)))
                    ((= 5 cindex) (setq colvar (vlax-make-variant 16711680 19) crocol (vlax-make-variant 16777215 19)))
                    ((= 6 cindex) (setq colvar (vlax-make-variant 16711935 19) crocol (vlax-make-variant 16777215 19)))
                    ((= 255 cindex) (setq colvar (vlax-make-variant 16777215 19) crocol (vlax-make-variant 0 19)))
                    (T (setq colvar (vlax-make-variant 0 19) crocol (vlax-make-variant 16777215 19)))
                )
            )
            ((= 'STR (type color)) (setq colvar (vlax-make-variant (atoi color) 19) crocol (vlax-make-variant (- 16777215 (atoi color)) 19)))
            (T (setq colvar (vlax-make-variant 0 19) crocol (vlax-make-variant 16777215 19)))
        )
        (list colvar crocol)
    )
    (setq 
        model (car (setq mvar (obtainColVar Modelcol)))
        mcro (cadr mvar)
        Layout (car (setq lvar (obtainColVar Layoutcol)))
        Lcro (cadr lvar)
        prefDisplay (vla-get-Display (vla-get-Preferences (vlax-get-acad-object)))
    )
    (if (/= Modelcol nil) 
        (progn;设定模型背景色
            (vla-put-GraphicsWinModelBackgrndColor prefDisplay model)
            (vla-put-ModelCrosshairColor prefDisplay mcro)
        )
    )
    (if (/= Layoutcol nil)
        (progn;设定布局背景色
            (vla-put-GraphicsWinLayoutBackgrndColor prefDisplay Layout)
            (vla-put-LayoutCrosshairColor prefDisplay Lcro)
        )
    )
)
(defun C:MBG(/ mindex)
    (setq Mindex "D")
    (while (or (equal Mindex "D") (equal Mindex "R"))
        (if (equal Mindex "D")
            (progn
                (initget 4 "r R")
                (setq Mindex (getint "\n请输入背景颜色值[黑(0)/红(1)/黄(2)/绿(3)/青(4)/蓝(5)/洋红(6)/白(255)/RGB模式(R)]默认：黑<0>"))
                (cond 
                    ((= Mindex nil) (setq Mindex 0))
                    ((or (equal Mindex "r") (equal Mindex "R")) (setq Mindex (strcase Mindex)))
                    ((or (< 6 Mindex 255) (> Mindex 255)) (princ "输入有误，请重新输入！") (setq Mindex "D"))
                )
            )
            (progn
                (setq Mindex (getstring "\n请输入背景颜色值[黑(0)/红(255)/黄(65535)/绿(65280)/青(16776960)/蓝(16711680)/洋红(16711935)/白(16777215)/系统模式(D)]"))
                (cond 
                    ((= Mindex "") (setq Mindex "0"))
                    ((or (equal Mindex "d") (equal Mindex "D")) (setq Mindex (strcase Mindex)))
                )
            )
        )
    )
    (Backgroundcolor Mindex nil)
    (prin1)
)
(defun C:LBG(/ Lindex)
    (setq Lindex "D")
    (while (or (equal Lindex "D") (equal Lindex "R"))
        (if (equal Lindex "D")
            (progn
                (initget 4 "r R")
                (setq Lindex (getint "\n请输入背景颜色值[黑(0)/红(1)/黄(2)/绿(3)/青(4)/蓝(5)/洋红(6)/白(255)/RGB模式(R)]默认：黑<0>"))
                (cond 
                    ((= Lindex nil) (setq Lindex 0))
                    ((or (equal Lindex "r") (equal Lindex "R")) (setq Lindex (strcase Lindex)))
                    ((or (< 6 Lindex 255) (> Lindex 255)) (princ "输入有误，请重新输入！") (setq Lindex "D"))
                )
            )
            (progn
                (setq Lindex (getstring "\n请输入背景颜色值[黑(0)/红(255)/黄(65535)/绿(65280)/青(16776960)/蓝(16711680)/洋红(16711935)/白(16777215)/系统模式(D)]"))
                (cond 
                    ((= Lindex "") (setq Lindex "0"))
                    ((or (equal Lindex "d") (equal Lindex "D")) (setq Lindex (strcase Lindex)))
                )
            )
        )
    )
    (Backgroundcolor nil Lindex)
    (prin1)
)
(princ "\n更改模型背景颜色：《 MBG 》更改布局背景颜色：《 LBG 》 by  702099480@qq.com")
(prin1)
;************************************************************************************
;(setq blackcol (vlax-make-variant 0 19));;黑色
;(setq redcol (vlax-make-variant 255 19));;红色
;(setq yellocol (vlax-make-variant 65535 19));;黄色
;(setq greencol (vlax-make-variant 65280 19));;绿色
;(setq cyancol (vlax-make-variant 16776960 19));;青色
;(setq bluecol (vlax-make-variant 16711680 19));;蓝色
;(setq magentacol (vlax-make-variant 16711935 19));;洋红
;(setq whitecol (vlax-make-variant 16777215 19));;白色
;设定背景色：深铅灰色3156001，白色16777215，黑色0
;end defun
;(Backgroundcolor 0 0)                    ;设置模型背景色为黑，布局背景色为黑
;(Backgroundcolor 3156001 16777215)       ;设置模型背景色为灰，布局背景色为白
;(Backgroundcolor 0 "g167fvfvsb")            ;设置模型背景色为黑，布局背景色为白
;************************************************************************************

40、判断线型”DASHED”是否加载，若未加载，则先加载线型！若不然会出错！
可以这样加载线型:

;;;(loadltname "CENTER")
;;;(loadltname '("CENTER" "DASHDOT" "DASHED" "DIVIDE" "HIDDEN"))
(defun loadltname ( lt / cm s1 )
  (setq cm (getvar 'CMDECHO))
  (Cond
    ((= (type lt) 'str)
      (if (not (tblsearch "LTYPE" lt))
        (vla-load (vla-get-Linetypes (vla-get-ActiveDocument (vlax-get-acad-object))) lt "acadiso.lin")
        (progn (setvar 'CMDECHO 0)(vl-cmdf "-linetype" "load" lt (findfile "acadiso.lin") "Y" "")(setvar 'CMDECHO cm))
      )
    )
    ((= (type lt) 'list)(foreach s1 lt (loadltname s1)))
  ) t
)
========================================================
(or
        (or (TBLSEARCH "LTYPE" "DASHED")
            (vl-catch-all-apply
                'vla-load
                (list (vla-get-Linetypes
                                (vla-get-ActiveDocument (vlax-get-acad-object))
                            )
                    "DASHED"
                    (findfile "zwcadiso.lin")
                )
            )
        );加载虚线
        (or (TBLSEARCH "LTYPE" "DASHED")
            (vl-catch-all-apply
                'vla-load
                (list (vla-get-Linetypes
                                (vla-get-ActiveDocument (vlax-get-acad-object))
                            )
                    "DASHED"
                    (findfile "acad.lin")
                )
            )
        )
    )