[原创]：Eachy 工具集 Lisp源码详解

eachy · 发表于 2008-12-29 16:16:42

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

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

×

本工具集为本人多年来积累的一些小程序并最终合成一个工具集，本贴将对该工具集的所有源码逐步予以公布并尽可能增加注释，最终打造一个开源的工具集。

首先说说工具集文件的构成，打包后仅包括了 vlx 主程序、mnu 菜单文件、mnl 自动加载文件、dll 图标文件。
主程序由若干个lisp 文件打包而成，为了便于程序的组织，这些 Lisp 文件依据功能单独保存为lisp文件：
1 Autolisp 通用函数文件，不在多而在精
2 ActivX 通用函数
3 DCL 操作通用函数
4 按实体类型操作的各个程序文件
5 专业性应用程序

复制代码

梦断江南 · 发表于 2008-12-29 16:55:53

支持!.........

eachy · 发表于 2008-12-29 17:17:54

第一部分通用Autolisp函数

命名规则：函数名一般由三部分 “前缀-类-说明”，前缀采用 ybl- ，用前缀可以和其他的程序避免冲突；类表示该函数处理分类（比如 String 、List 等）。

(princ (vl-list->string
'(61 61 69 97 99 104 121 32 185 164 190 223
188 175 44 32 69 97 99 104 121 91 101 97
99 104 121 64 50 49 99 110 46 99 111 109
93 61 61
)
)
);_说明，编译后可以起到一定的防止盗版功能
(foreach x (if (< (atof (getvar "acadver")) 16.)
'("acadapp.arx" "geom3d.arx" "acadvba.arx")
'("acapp.arx" "geom3d.arx" "acvba.arx")
)
(if (not (member x (arx)))
(arxload x)
)
);_增加一些必要的内置函数
(mapcar 'vl-arx-import
'(ACAD_COLORDLG ACAD_truecolordlg ACAD_STRLSORT
INITDIA ACAD-POP-DBMOD ACAD-PUSH-DBMOD
STARTAPP layoutlist
)
)
(vlax-add-cmd "ea:about" 'ea:about)
(defun ea:about ()
(alert
(vl-list->string
'(10 32 69 97 99 104 121 32 65 117 116 111
108 105 115 112 47 86 105 115 117 97 108 32
76 105 115 112 32 205 168 211 195 186 175 202
253 191 226 10 10 32 32 32 32 32 32 32
65 117 116 104 111 114 58 32 101 97 99 104
121 10 32 32 32 32 32 32 32 32 69 109
97 105 108 58 32 32 32 101 97 99 104 121
64 50 49 99 110 46 99 111 109
)
)
)
)
;;常量定义
(setq *Acad* (vlax-get-acad-object)
*AcDocument* (vla-get-activedocument *Acad*)
*ModelSpace* (vla-get-modelspace *AcDocument*)
*INFINITY* 1.7e308 ;_ largest double
_pi2 (* pi 0.5)
_pi4 (* pi 0.25)
_2pi (* pi 2.)
_3pi (* 1.5 pi)
)
;;取得组码
(defun ybl-dxf (code lst)
(cdr (assoc code lst))
)
;;取取相同的组码，也可以在程序内用 vl-reomve-if
(defun ybl-massoc (code lst)
(foreach x lst
(if (= (car x) code)
(setq ll (cons (cdr x) ll))
)
)
(reverse ll)
)
;;获取拾取框大小
(defun ybl-pickbox ()
(* (getvar "pickbox")
(/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))
)
)
;;选择集处理，不一定常用
(defun ybl-SSMAP (fun ss / n)
(if (= 'PICKSET (type ss))
(progn
(setq n (sslength ss))
(repeat n
(apply fun (list (ssname ss (setq n (- n 1)))))
)
)
)
)
;;角度转化
(defun ybl-rtd (j$) (/ (* j$ 180.0) pi))
;;度转换为弧度
(defun ybl-dtr (j$) (* (/ j$ 180.0) pi))
;;在获取程序运行时间的时候使用
(defun ybl-getutime ()
(* 86400 (getvar "tdusrtimer"))
)
;|;一个在状态条显示处理进度的函数
;; k 数 l 长度
(defun ybl-pross (k l)
(grtext -2
(strcat "已完成 "
(rtos (/ (* 100.0 k) l)
2
0
)
"%...."
)
)
)|;
;;;功能返回包含在指定符号表中的所有元素
;;;参数一个符号表名称
;;;示例 (ybl-table "block")
;;;作者 Michael Puckett
(defun ybl-table (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
(reverse r)
)
;;*************************************************************
;;临时取消捕捉
(defun ybl-osmode (/ os)
(if (>= (setq os (getvar "osmode")) 16384)
(setvar "osmode" (- os 16384))
(setvar "osmode" (+ os 16384))
)
(princ)
)

(princ (vl-list->string 
         '(61        61   69          97   99   104         121  32   185        164  190  223 
           188        175  44          32   69   97         99   104  121        91   101  97 
           99        104  121  64   50   49         99   110  46        99   111  109 
           93        61   61 
          ) 
       ) 
);_说明，编译后可以起到一定的防止盗版功能 
 
(foreach x (if (< (atof (getvar "acadver")) 16.) 
             '("acadapp.arx" "geom3d.arx" "acadvba.arx") 
             '("acapp.arx" "geom3d.arx" "acvba.arx") 
           ) 
  (if (not (member x (arx))) 
    (arxload x) 
  ) 
);_增加一些必要的内置函数 
(mapcar        'vl-arx-import 
        '(ACAD_COLORDLG             ACAD_truecolordlg        ACAD_STRLSORT 
          INITDIA             ACAD-POP-DBMOD        ACAD-PUSH-DBMOD 
          STARTAPP             layoutlist 
         ) 
) 
(vlax-add-cmd "ea:about" 'ea:about) 
(defun ea:about        () 
  (alert 
    (vl-list->string 
      '(10   32          69   97   99         104  121  32        65   117  116  111 
        108  105  115  112  47         86   105  115        117  97          108  32 
        76   105  115  112  32         205  168  211        195  186  175  202 
        253  191  226  10   10         32   32   32        32   32          32   32 
        65   117  116  104  111         114  58   32        101  97          99   104 
        121  10          32   32   32         32   32   32        32   32          69   109 
        97   105  108  58   32         32   32   101        97   99          104  121 
        64   50          49   99   110         46   99   111        109 
       ) 
    ) 
  ) 
) 
;;常量定义 
(setq *Acad*           (vlax-get-acad-object) 
      *AcDocument* (vla-get-activedocument *Acad*) 
      *ModelSpace* (vla-get-modelspace *AcDocument*) 
      *INFINITY*   1.7e308 ;_ largest double 
      _pi2           (* pi 0.5) 
      _pi4           (* pi 0.25) 
      _2pi           (* pi 2.) 
      _3pi           (* 1.5 pi) 
) 
;;取得组码 
(defun ybl-dxf (code lst) 
  (cdr (assoc code lst)) 
) 
;;取取相同的组码，也可以在程序内用 vl-reomve-if 
(defun ybl-massoc (code lst) 
  (foreach x lst 
    (if        (= (car x) code) 
      (setq ll (cons (cdr x) ll)) 
    ) 
  ) 
  (reverse ll) 
) 
;;获取拾取框大小 
(defun ybl-pickbox () 
  (* (getvar "pickbox") 
     (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) 
  ) 
) 
;;选择集处理，不一定常用 
(defun ybl-SSMAP (fun ss / n) 
  (if (= 'PICKSET (type ss)) 
    (progn 
      (setq n (sslength ss)) 
      (repeat n 
        (apply fun (list (ssname ss (setq n (- n 1))))) 
      ) 
    ) 
  ) 
) 
;;角度转化 
(defun ybl-rtd (j$) (/ (* j$ 180.0) pi)) 
;;度转换为弧度 
(defun ybl-dtr (j$) (* (/ j$ 180.0) pi)) 
;;在获取程序运行时间的时候使用 
(defun ybl-getutime () 
  (* 86400 (getvar "tdusrtimer")) 
) 
 ;|;一个在状态条显示处理进度的函数 
;; k 数 l 长度 
(defun ybl-pross        (k l) 
  (grtext -2 
          (strcat "已完成 " 
                  (rtos        (/ (* 100.0 k) l) 
                        2 
                        0 
                  ) 
                  "%...." 
          ) 
  ) 
)|; 
;;;功  能  返回包含在指定符号表中的所有元素 
;;;参  数  一个符号表名称 
;;;示  例  (ybl-table "block") 
;;;作  者  Michael Puckett 
(defun ybl-table (s / d r) 
  (while (setq d (tblnext s (null d))) 
    (setq r (cons (cdr (assoc 2 d)) r)) 
  ) 
  (reverse r) 
) 
;;************************************************************* 
;;临时取消捕捉 
(defun ybl-osmode (/ os) 
  (if (>= (setq os (getvar "osmode")) 16384) 
    (setvar "osmode" (- os 16384)) 
    (setvar "osmode" (+ os 16384)) 
  ) 
  (princ) 
)

c_wm · 发表于 2008-12-29 19:12:40

支持eachy大哥！lisp通用函数无私放出第一人。

zx0sl · 发表于 2008-12-30 11:59:30

eachy版主果然有风范啊，强烈支持

dwg001 · 发表于 2009-1-2 10:15:56

不仅仅是水平，更是胸怀，令后学敬仰！

taner · 发表于 2009-1-2 21:58:08

老大，来个每日一贴，行不？俺等得好心焦！

eachy · 发表于 2009-1-3 19:26:35

最初由 taner 发布
[B]老大，来个每日一贴，行不？俺等得好心焦！ [/B]

工具集成形是 2004 年，之前用 xdrx_api 写了些晓东工具箱程序，再后来随着 Autocad 版本的升级，就想整理套 Alisp 工具，可以尽可能少的受版本限制。大概用了半年左右的时间学习了 ActivX 部分，边学边写，整合了些自己写的工具。
期间由于硬盘故障遭遇源码丢失，留下的一些文件大都不完整，再后来也就没有心思去完善，40901 是目前用的最后版本。
发这个帖子还要对那些文件重新整理，这需要时间，我会尽力的，毕竟 Lisp 只是在业余时间玩玩。

nwushaoshuai · 发表于 2009-1-4 08:49:07

支持eachy大哥！

它山之石 · 发表于 2009-1-4 13:07:58

最终打造一个开源的工具集

新版晓东工具箱　？

支持一下开源先

carrot1983 · 发表于 2009-1-4 14:31:29

刚开帖的那一刻我就来看了。。。
大师的帖，本来想抢沙发的。
但是没有实如质性的回复内容，实在没敢回复。。。
看到其它的回复，放心啦。。。
支持ea。。。

eachy · 发表于 2009-1-4 15:06:32

不管什么工具，最终都要 Plot 出图纸，这就要涉及到一个比例，用来控制文字、标注等，这个比例的最好能随图保存，这样只要在加载自己的工具后都可以读取该比例。

随图保存有多种方案，最好的应该是用词典，vlax-ldata-* 提供的方便的存取方法。

;; 米 0.001 毫米 1.0
(defun c:Ea:SetScal (/ $do_default $ea:do_units
$ea:do_scale $ea_scale _easet_id
ea:selst hlst edit_in
ea:units slst
)
(defun edit_in (n val / ppt k1 lst)
(setq
lst (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|")
)
(cond ((= n 1)
(setq ppt "出图比例"
k1 "scal"
)
)
((= n 2)
(setq ppt "字体高度"
k1 "hig"
)
)
)
(if ($EADCL_CheckIn val ppt k1)
(cond
((= n 1)
(vlax-ldata-put
"Ea_dict"
"ea_contrl"
(strcat (get_tile "scal") "|" (cadr lst) "|" (last lst))
)
)
((= n 2)
(vlax-ldata-put
"Ea_dict"
"ea_contrl"
(strcat (car lst) "|" (cadr lst) "|" (get_tile "hig"))
)
)
)
)
)
(defun $do_default (/ lst)
(setq
lst (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|")
)
(set_tile "scal" (car lst))
(set_tile "hig" (last lst))
(if (= 1.0 (float (read (cadr lst))))
(set_tile "un_h" "1")
(set_tile "un_m" "1")
)
;;($EADCL_AddList "hig_list" (mapcar 'vl-princ-to-string hlst) 1)
;;($EADCL_AddList "scal_list" (mapcar 'itoa slst) 3)
)
(defun ea:selst (/ lst indx dlst)
(setq
dlst
(ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|")
)
(setq indx (atoi (get_tile "scal_list")))
(set_tile "scal"
(itoa (nth indx slst))
)
(vlax-ldata-put
"Ea_dict"
"ea_contrl"
(strcat (vl-princ-to-string (float (nth indx slst)))
"|"
(cadr dlst)
"|"
(last dlst)
)
)
)
(defun $fillhig (/ dlst)
(setq
dlst
(ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|")
)
(set_tile "hig"
(vl-princ-to-string (nth (atoi $value) hlst))
)
(vlax-ldata-put
"Ea_dict"
"ea_contrl"
(strcat (car dlst) "|" (cadr dlst) "|" (get_tile "hig"))
)
)
(defun ea:units (num / lst)
(setq
lst (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|")
)
(vlax-ldata-put
"Ea_dict"
"ea_contrl"
(strcat (car lst)
(if (= 0 num)
"|0.001|"
"|1.0|"
)
(last lst)
)
)
)
(ea:init)
(setq hlst '(2.0 2.5 3.0 3.5 4.0 4.5 5.0)
slst '(100 200 300 500 1000 1500 2000 3000 5000 10000 25000 50000 100000))
(if (not _easet_id)
(setq _easet_id (load_dialog "scale.dcl"))
)
(if (not (new_dialog "ea_setgloble" _easet_id))
(exit)
)
($do_default)
(action_tile "scal" "(edit_in 1 $value)")
(action_tile "scal_list" "(ea:selst)")
(action_tile "un_m" "(ea:units 0)")
(action_tile "un_h" "(ea:units 1)")
(action_tile "hig" "(edit_in 2 $value)")
(action_tile "hig_list" "($fillhig)")
(start_dialog)
(unload_dialog _easet_id)
(princ)
(princ)
)

;; 米 0.001 毫米  1.0 
(defun c:Ea:SetScal (/                   $do_default         $ea:do_units 
                     $ea:do_scale  $ea_scale         _easet_id 
                     ea:selst           hlst                 edit_in 
                     ea:units      slst 
                    ) 
  (defun edit_in (n val / ppt k1 lst) 
    (setq 
      lst (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|") 
    ) 
    (cond ((= n 1) 
           (setq ppt "出图比例" 
                 k1  "scal" 
           ) 
          ) 
          ((= n 2) 
           (setq ppt "字体高度" 
                 k1  "hig" 
           ) 
          ) 
    ) 
    (if        ($EADCL_CheckIn val ppt k1) 
      (cond 
        ((= n 1) 
         (vlax-ldata-put 
           "Ea_dict" 
           "ea_contrl" 
           (strcat (get_tile "scal") "|" (cadr lst) "|" (last lst)) 
         ) 
        ) 
        ((= n 2) 
         (vlax-ldata-put 
           "Ea_dict" 
           "ea_contrl" 
           (strcat (car lst) "|" (cadr lst) "|" (get_tile "hig")) 
         ) 
        ) 
      ) 
    ) 
  ) 
  (defun $do_default (/ lst) 
    (setq 
      lst (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|") 
    ) 
    (set_tile "scal" (car lst)) 
    (set_tile "hig" (last lst)) 
    (if        (= 1.0 (float (read (cadr lst)))) 
      (set_tile "un_h" "1") 
      (set_tile "un_m" "1") 
    ) 
    ;;($EADCL_AddList "hig_list" (mapcar 'vl-princ-to-string hlst) 1) 
    ;;($EADCL_AddList "scal_list" (mapcar 'itoa slst) 3) 
  ) 
  (defun ea:selst (/ lst indx dlst) 
    (setq 
      dlst 
       (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|") 
    ) 
    (setq indx (atoi (get_tile "scal_list"))) 
    (set_tile "scal" 
              (itoa (nth indx slst)) 
    ) 
    (vlax-ldata-put 
      "Ea_dict" 
      "ea_contrl" 
      (strcat (vl-princ-to-string (float (nth indx slst))) 
              "|" 
              (cadr dlst) 
              "|" 
              (last dlst) 
      ) 
    ) 
  ) 
  (defun $fillhig (/ dlst) 
    (setq 
      dlst 
       (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|") 
    ) 
    (set_tile "hig" 
              (vl-princ-to-string (nth (atoi $value) hlst)) 
    ) 
    (vlax-ldata-put 
      "Ea_dict" 
      "ea_contrl" 
      (strcat (car dlst) "|" (cadr dlst) "|" (get_tile "hig")) 
    ) 
  ) 
  (defun ea:units (num / lst) 
    (setq 
      lst (ybl-str-parse (vlax-ldata-get "Ea_dict" "ea_contrl") "|") 
    ) 
    (vlax-ldata-put 
      "Ea_dict" 
      "ea_contrl" 
      (strcat (car lst) 
              (if (= 0 num) 
                "|0.001|" 
                "|1.0|" 
              ) 
              (last lst) 
      ) 
    ) 
  ) 
  (ea:init) 
  (setq hlst '(2.0 2.5 3.0 3.5 4.0 4.5 5.0) 
        slst '(100 200 300 500 1000 1500 2000 3000 5000 10000 25000 50000 100000)) 
  (if (not _easet_id) 
    (setq _easet_id (load_dialog "scale.dcl")) 
  ) 
  (if (not (new_dialog "ea_setgloble" _easet_id)) 
    (exit) 
  ) 
  ($do_default) 
  (action_tile "scal" "(edit_in 1 $value)") 
  (action_tile "scal_list" "(ea:selst)") 
  (action_tile "un_m" "(ea:units 0)") 
  (action_tile "un_h" "(ea:units 1)") 
  (action_tile "hig" "(edit_in 2 $value)") 
  (action_tile "hig_list" "($fillhig)") 
  (start_dialog) 
  (unload_dialog _easet_id) 
  (princ) 
  (princ) 
)

配套的 DCL

ea_setgloble: dialog {
label = "绘图参数 EaTools";
: row {
fixed_width = true;
: boxed_column {
label = "出图比例";
: edit_box {
key = "scal";
fixed_width = true;
edit_width = 8;
edit_limit = 8;
mnemonic = "C";
}
: popup_list {
key = "scal_list";
edit_width = 10;
list = "1:100\n1:200\n1:300\n1:500\n1:1000\n1:1500\n1:2000\n1:3000\n1:5000\n1:10000\n1:25000\n1:50000\n1:250000\n1:1000000";
}
}
: boxed_column {
label = "绘图单位";
: radio_button {
label = "米M";
mnemonic = "M";
key = "un_m";
is_tab_stop = false;
}
: radio_button {
label = "毫米H";
mnemonic = "H";
key = "un_h";
is_tab_stop = false;
}
}
}
: boxed_row {
label = "文字高度: ";
: edit_box {
label = "H:";
key = "hig";
fixed_width = true;
edit_width = 8;
}
: popup_list {
key = "hig_list";
edit_width = 8;
list = "2.0\n2.5\n3.0\n3.5\n4.0\n4.5\n5.0";
}
}
ok_cancel;
}

ea_setgloble: dialog { 
  label  = "绘图参数 EaTools"; 
  : row { 
    fixed_width = true; 
    : boxed_column { 
      label = "出图比例";    
      : edit_box { 
        key = "scal"; 
        fixed_width = true; 
        edit_width = 8; 
        edit_limit = 8; 
        mnemonic = "C"; 
        } 
      : popup_list { 
        key = "scal_list"; 
        edit_width = 10; 
        list = "1:100\n1:200\n1:300\n1:500\n1:1000\n1:1500\n1:2000\n1:3000\n1:5000\n1:10000\n1:25000\n1:50000\n1:250000\n1:1000000"; 
        } 
      } 
      : boxed_column { 
        label = "绘图单位"; 
        : radio_button { 
          label       = "米M"; 
          mnemonic    = "M"; 
          key         = "un_m"; 
          is_tab_stop = false; 
          } 
        : radio_button { 
          label       = "毫米H"; 
          mnemonic    = "H"; 
          key         = "un_h"; 
          is_tab_stop = false; 
          } 
        } 
    } 
  : boxed_row { 
    label = "文字高度: "; 
    : edit_box { 
      label = "H:"; 
      key = "hig"; 
      fixed_width = true; 
      edit_width = 8; 
      } 
    : popup_list { 
      key = "hig_list"; 
      edit_width = 8; 
      list = "2.0\n2.5\n3.0\n3.5\n4.0\n4.5\n5.0"; 
      } 
    }       
  ok_cancel; 
}

eachy · 发表于 2009-1-4 15:18:29

再贴几个 String 处理函数

;;============================================================
(defun ybl-str-parse (str delimiter / post strlst sl)
(if str
(progn
(setq strlst '()
sl (+ (strlen delimiter) 1)
)
(while (vl-string-search delimiter str)
(setq post (vl-string-search delimiter str))
(setq strlst (append strlst (list (substr str 1 post))))
(setq str (substr str (+ post sl)))
)
(vl-remove "" (append strlst (list str)))
)
)
)
(defun ybl-str-unparse (lst delimiter / return)
(setq return "")
(foreach str lst
(setq return (strcat return delimiter str))
)
(substr return 2)
)
(defun ybvl-Str-Reverse (string / oldusers str)
(setq oldusers (getvar "USERS1"))
(vl-catch-all-apply
'(lambda ()
(vla-eval
*Acad*
(strcat "ThisDrawing.SetVariable "USERS1", StrReverse(""
string
"")"
)
)
(setq str (getvar "USERS1"))
)
)
(setvar "USERS1" oldusers)
str
)
(defun ybvl-Str-Replace (string Oldstr Newstr / oldusers str)
(setq oldusers (getvar "USERS1"))
(vl-catch-all-apply
'(lambda ()
(vla-eval
*Acad*
(strcat
"ThisDrawing.SetVariable "USERS1", Replace(""
string "", ""
Oldstr "", ""
newstr "")"
)
)
(setq str (getvar "USERS1"))
)
)
(setvar "USERS1" oldusers)
str
)
;|
vbUpperCase 1 将字符串文字转成大写。
vbLowerCase 2 将字符串文字转成小写。
vbProperCase 3 将字符串中每个字的开头字母转成大写。
vbWide* 4* 将字符串中单字节字符转成双字节字符。
vbNarrow* 8* 将字符串中双字节字符转成单字节字符。
vbKatakana** 16** 将字符串中平假名字符转成片假名字符。
vbHiragana** 32** 将字符串中片假名字符转成平假名字符。
vbUnicode 64 根据系统的缺省码页将字符串转成 Unicode。 (在Macintosh中不可用。)
vbFromUnicode 128 将字符串由 Unicode 转成系统的缺省码页。 (在Macintosh中不可用。)
|;
(defun ybvl-str-strconv (string mode / str oldusers)
(setq oldusers (getvar "USERS1"))
(vl-catch-all-apply
'(lambda ()
(vla-eval
*Acad*
(strcat
"ThisDrawing.SetVariable "USERS1", StrconV(""
string
"", "
(itoa mode)
")"
)
)
(setq str (getvar "USERS1"))
)
)
(setvar "USERS1" oldusers)
str
)

;;============================================================ 
(defun ybl-str-parse (str delimiter / post strlst sl) 
  (if str 
    (progn 
      (setq strlst '() 
            sl           (+ (strlen delimiter) 1) 
      ) 
      (while (vl-string-search delimiter str) 
        (setq post (vl-string-search delimiter str)) 
        (setq strlst (append strlst (list (substr str 1 post)))) 
        (setq str (substr str (+ post sl))) 
      ) 
      (vl-remove "" (append strlst (list str))) 
    ) 
  ) 
) 
(defun ybl-str-unparse (lst delimiter / return) 
  (setq return "") 
  (foreach str lst 
    (setq return (strcat return delimiter str)) 
  ) 
  (substr return 2) 
) 
(defun ybvl-Str-Reverse        (string / oldusers str) 
  (setq oldusers (getvar "USERS1")) 
  (vl-catch-all-apply 
    '(lambda () 
       (vla-eval 
         *Acad* 
         (strcat "ThisDrawing.SetVariable "USERS1", StrReverse("" 
                 string 
                 "")" 
         ) 
       ) 
       (setq str (getvar "USERS1")) 
     ) 
  ) 
  (setvar "USERS1" oldusers) 
  str 
) 
(defun ybvl-Str-Replace        (string Oldstr Newstr / oldusers str) 
  (setq oldusers (getvar "USERS1")) 
  (vl-catch-all-apply 
    '(lambda () 
       (vla-eval 
         *Acad* 
         (strcat 
           "ThisDrawing.SetVariable "USERS1", Replace("" 
           string                       "", "" 
           Oldstr                       "", "" 
           newstr                       "")" 
          ) 
       ) 
       (setq str (getvar "USERS1")) 
     ) 
  ) 
  (setvar "USERS1" oldusers) 
  str 
) 
 ;| 
vbUpperCase 1 将字符串文字转成大写。 
vbLowerCase 2 将字符串文字转成小写。 
vbProperCase 3 将字符串中每个字的开头字母转成大写。 
vbWide* 4* 将字符串中单字节字符转成双字节字符。 
vbNarrow* 8* 将字符串中双字节字符转成单字节字符。 
vbKatakana** 16** 将字符串中平假名字符转成片假名字符。 
vbHiragana** 32** 将字符串中片假名字符转成平假名字符。 
vbUnicode 64 根据系统的缺省码页将字符串转成 Unicode。 (在Macintosh中不可用。) 
vbFromUnicode 128 将字符串由 Unicode 转成系统的缺省码页。 (在Macintosh中不可用。) 
|; 
(defun ybvl-str-strconv        (string mode / str oldusers) 
  (setq oldusers (getvar "USERS1")) 
  (vl-catch-all-apply 
    '(lambda () 
       (vla-eval 
         *Acad* 
         (strcat 
           "ThisDrawing.SetVariable "USERS1", StrconV("" 
           string 
           "", " 
           (itoa mode) 
           ")" 
         ) 
       ) 
       (setq str (getvar "USERS1")) 
     ) 
  ) 
  (setvar "USERS1" oldusers) 
  str 
)

eachy · 发表于 2009-1-4 15:26:02

几个 DCL 通用函，功能比较简单，文件名可以保存为 lib_dcl.lsp

(defun ybl-dcl-AddList (key val item)
(start_list key)
(foreach n val
(add_list n)
)
(end_list)
(set_tile key (itoa item))
)
(defun ybl-dcl-SlideImage (key sldname color / x y)
(setq x (dimx_tile key)
y (dimy_tile key)
)
(start_image key)
(fill_image 0 0 x y color)
(slide_image 0 0 x y sldname)
(end_image)
)
(defun ybl-dcl-ImageFillColor (key color)
(setq x (dimx_tile key)
y (dimy_tile key)
)
(start_image key)
(fill_image 0 0 x y color)
(slide_image 0 0 x y key)
(end_image)
(mode_tile key 1)
)
(defun ybl-dcl-ImageCrlDisable (key)
(mapcar
'(lambda (x)
(ybl-dcl-ImageFillColor x 253)
)
key
)
)
(defun ybl-dcl-CtrlEnable (clist)
(mapcar
'(lambda (x)
(mode_tile x 0)
)
clist
)
)
(defun ybl-dcl-CtrlDisable (clist)
(mapcar
'(lambda (x)
(mode_tile x 1)
)
clist
)
)
(defun ybl-dcl-RsError ()
(set_tile "error" "")
)
(defun ybl-dcl-doseterror (val)
(ybl-dcl-Rs_Error)
(set_tile "error" val)
)
;;检查输入格式
(defun ybl-dcl-CheckIn (input format kk /)
(if (and (distof input 2) (> (atof input) 0))
(progn (ybl-dcl-Rs_Error) input)
(progn
(ybl-dcl-do_set_error (strcat "无效的" format "输入"))
(mode_tile kk 2)
nil
)
)
)

(defun ybl-dcl-AddList (key val item) 
  (start_list key) 
  (foreach n val 
    (add_list n) 
  ) 
  (end_list) 
  (set_tile key (itoa item)) 
) 
(defun ybl-dcl-SlideImage (key sldname color / x y) 
  (setq        x (dimx_tile key) 
        y (dimy_tile key) 
  ) 
  (start_image key) 
  (fill_image 0 0 x y color) 
  (slide_image 0 0 x y sldname) 
  (end_image) 
) 
(defun ybl-dcl-ImageFillColor (key color) 
  (setq        x (dimx_tile key) 
        y (dimy_tile key) 
  ) 
  (start_image key) 
  (fill_image 0 0 x y color) 
  (slide_image 0 0 x y key) 
  (end_image) 
  (mode_tile key 1) 
) 
(defun ybl-dcl-ImageCrlDisable (key) 
  (mapcar 
    '(lambda (x) 
       (ybl-dcl-ImageFillColor x 253) 
     ) 
    key 
  ) 
) 
(defun ybl-dcl-CtrlEnable (clist) 
  (mapcar 
    '(lambda (x) 
       (mode_tile x 0) 
     ) 
    clist 
  ) 
) 
(defun ybl-dcl-CtrlDisable (clist) 
  (mapcar 
    '(lambda (x) 
       (mode_tile x 1) 
     ) 
    clist 
  ) 
) 
(defun ybl-dcl-RsError () 
  (set_tile "error" "") 
) 
(defun ybl-dcl-doseterror (val) 
  (ybl-dcl-Rs_Error) 
  (set_tile "error" val) 
) 
;;检查输入格式 
(defun ybl-dcl-CheckIn (input format kk /) 
  (if (and (distof input 2) (> (atof input) 0)) 
    (progn (ybl-dcl-Rs_Error) input) 
    (progn 
      (ybl-dcl-do_set_error (strcat "无效的" format "输入")) 
      (mode_tile kk 2) 
      nil 
    ) 
  ) 
)

eachy · 发表于 2009-1-4 15:35:49

这个是 Lib_make.lsp ，其实很多不一定用的到

(defun ybl-mkpline (pts)
(if (entmake (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pts))
)
(mapcar '(lambda (x) (cons 10 x)) pts)
'((210 0. 0. 1.))
)
)
(entlast)
)
)
(defun ybl-mkcircle (p r)
(if (entmake (list '(0 . "CIRCLE")
'(100 . "AcDbEntity")
'(100 . "ACDbCircle")
(cons 10 p)
(cons 40 r)
'(210 0. 0. 1.)
)
)
(entlast)
)
)
(defun ybl-mkline (p1 p2)
(if (entmake (list '(0 . "LINE")
'(100 . "AcDbEntity")
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'(210 0. 0. 1.)
)
)
(entlast)
)
)
;;字串插入点高度宽度因子
(defun ybl-mktxt (string insertionpt hight width)
(if (entmake (list '(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 1 string)
(cons 10 insertionpt)
(cons 40 hight)
(cons 41 width)
)
)
(entlast)
)
)
;;d70线性32对齐33; p10基点 p13第一点 p14第二点 d1强制长度值
(defun ybl-MkDimAlign (p1 p2 p3 /)
(if (entmake (list '(0 . "DIMENSION")
'(100 . "AcDbEntity")
'(100 . "AcDbDimension")
(cons 10 p3)
'(11 0. 0. 0.)
'(70 . 32)
'(100 . "AcDbAlignedDimension")
(cons 13 p1)
(cons 14 p2)
(cons 50 (angle p1 p2))
'(100 . "AcDbRotatedDimension")
)
)
(entlast)
)
)
;;;制造角度标注
;;(#m_dim '线 '脚1 '脚2 '圆心)
;;d70=5,37,133,165
(defun ybl-MkDimAngle (p10 p13 p14 p15 / en000)
(if (entmake (list
'(0 . "DIMENSION")
'(100 . "AcDbEntity")
'(100 . "AcDbDimension")
(cons 10 p10) ;线,注意应在弧线内
'(11 0 0 0) ;字
'(70 . 5)
'(100 . "AcDb3PointAngularDimension")
(cons 13 p13) ;脚1
(cons 14 p14) ;脚2
(cons 15 p15) ;圆心
)
)
(entlast)
)
)
;;;==========
(defun ybl-MKblock (blockname ins-pt)
;;;做块头
(entmake (list
'(0 . "BLOCK")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockBegin")
(cons 2 blockname)
'(70 . 2)
(cons 10 ins-pt)
)
)
)
(defun ybl-MKENDBLK (lay)
;;;做块尾
(entmake (list
'(0 . "ENDBLK")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockEnd")
)
)
)
(defun ybl-MkINSERT (bname ins-pt)
;;;插入图块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1)
(cons 2 bname)
(cons 10 ins-pt)
)
)
)
(defun ybl-MKATTRIB (txt-str ins-pt txt-ht txt-style lay)
;;;加入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
(cons 8 lyr)
'(100 . "AcDbText")
(cons 10 ins-pt)
(cons 40 txt-ht)
(cons 1 txt-str)
(cons 7 txt-style)
'(100 . "AcDbAttribute")
(cons 2 t-str)
'(70 . 0)
)
)
(entmake '((0 . "SEQEND")))
)
;;;==========
;;制造 SOLID ;input : pt1 pt2 pt3 pt4
(defun ybl-MkSolid (pt1 pt2 pt3 pt4 /)
(if (entmake (list
(cons 0 "SOLID")
(cons 10 pt1)
(cons 11 pt2)
(cons 12 pt3)
(cons 13 pt4)
)
)
(entlast)
)
)
;;;画圆环 r1内径r2 外径
(defun ybl-MkDonut (p0 r1 r2 / P1 P2 R RR)
(setq r (/ (+ r1 r2) 2.0)
rr (- r2 r1)
p1 (polar p0 0 (- r))
p2 (polar p0 0 r)
)
(if (entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(100 . "AcDbPolyline")
'(90 . 2)
'(70 . 1)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 p1)
(cons 40 rr)
(cons 41 rr)
'(42 . 1.0)
(cons 10 p2)
(cons 40 rr)
(cons 41 rr)
'(42 . 1.0)
)
)
(entlast)
)
)
;;制造 TRACE ;input : pt1 pt2 pt3 pt4
(defun ybl-MkTrace (pt1 pt2 pt3 pt4 /)
(if (entmake (list
(cons 0 "TRACE")
(cons 10 pt1)
(cons 11 pt2)
(cons 12 pt3)
(cons 13 pt4)
)
)
(entlast)
)
)
;;制造 3DFACE ; input : pt1 pt2 pt3 pt4
;; control flag
(defun ybl-Mk3dface (pt1 pt2 pt3 pt4 flag / en000) ;flag=1248
(if (entmake (list
(cons 0 "3DFACE")
(cons 8 lay)
(cons 10 pt1)
(cons 11 pt2)
(cons 12 pt3)
(cons 13 pt4)
(cons 70 flag)
)
)
(entlast)
)
)
;;制造 RAY ; input: 起始 pt1 终止角ANG
(defun ybl-MkRay (pt1 ang /)
(if (entmake (list
(cons 0 "RAY")
'(100 . "AcDbEntity")
'(67 . 0)
'(100 . "AcDbRay")
(cons 8 lay)
(cons 10 pt1)
(cons 11 (list (cos ang) (sin ang)))
)
)
(entlast)
)
)
;;制造 XLINE ; input: 起始 pt1 终止角ANG
(defun ybl-MkXlin (pt1 ang / en000)
(if (entmake (list
(cons 0 "XLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(100 . "AcDbXline")
(cons 10 pt1)
(cons 11 (list (cos ang) (sin ang)))
)
)
(entlast)
)
)
;;;============================
(defun #m_style (stynam styw styo styxw styzw / en)
;;造字型
(setq e (tblobjname "style" stynam))
(if e
(progn
(setq en (entget e)
en (cy_asubst en
(list
(cons 2 stynam)
(cons 41 styw)
(cons 50 styo)
(cons 3 styxw)
(cons 4 styzw)
)
)
)
(entmod en)
)
(progn
(setq en (list
'(0 . "STYLE")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbTextStyleTableRecord")
(cons 2 stynam)
'(70 . 0)
'(40 . 0)
(cons 41 styw)
(cons 50 styo)
'(71 . 0)
(cons 3 styxw)
(cons 4 styzw)
)
)
(entmake en)
)
)
)
;;(#m_style "ddd" 0.8 0 "romans.shx" "dxfs.shx")没有后者为西文romans,romanc,standard,
;;;;建立字型
;;;(#m_style "standard" 0.6 (/ pi 12) "romans.shx" "")
;;;(#m_style "dxfs" 0.7 0 "romans.shx" "dxfs.shx")
;;;(#m_style "s" 1 0 "romanc.shx" "s.shx")
;;;(setvar "textstyle" "dxfs")
(defun ybl-mktxtalign
(entity pts mode / ea:subst insertionpt alignpt entlst)
(defun ea:subst (item oldlst)
(foreach i item
(setq oldlst (subst i (assoc (car i) oldlst) oldlst))
)
)
(if (= (length pts) 2)
(setq insertionpt (cons 10 (car pts))
alignpt (cons 11 (cadr pts))
)
(setq alignpt (cons 11 pts))
)
(setq entlst (entget entity))
(entmod
(cond
((= (strcase mode) "L")
(ea:subst (list (cons 10 pts) '(72 . 0) '(73 . 0)) entlst)
)
((= (strcase mode) "C")
(ea:subst (list alignpt '(72 . 1) '(73 . 0)) entlst)
)
((= (strcase mode) "R")
(ea:subst (list alignpt '(72 . 2) '(73 . 0)) entlst)
)
((= (strcase mode) "M")
(ea:subst (list alignpt '(72 . 4) '(73 . 0)) entlst)
)
((= (strcase mode) "A")
(ea:subst (list insertionpt alignpt '(72 . 3) '(73 . 0))
entlst
)
)
((= (strcase mode) "F")
(ea:subst (list insertionpt alignpt '(72 . 5) '(73 . 0))
entlst
)
)
((= (strcase mode) "BL")
(ea:subst (list alignpt '(72 . 0) '(73 . 1)) entlst)
)
((= (strcase mode) "BC")
(ea:subst (list alignpt '(72 . 1) '(73 . 1)) entlst)
)
((= (strcase mode) "BR")
(ea:subst (list alignpt '(72 . 1) '(73 . 1)) entlst)
)
((= (strcase mode) "ML")
(ea:subst (list alignpt '(72 . 0) '(73 . 2)) entlst)
)
((= (strcase mode) "MC")
(ea:subst (list alignpt '(72 . 1) '(73 . 2)) entlst)
)
((= (strcase mode) "MR")
(ea:subst (list alignpt '(72 . 2) '(73 . 2)) entlst)
)
((= (strcase mode) "TL")
(ea:subst (list alignpt '(72 . 0) '(73 . 3)) entlst)
)
((= (strcase mode) "TC")
(ea:subst (list alignpt '(72 . 1) '(73 . 3)) entlst)
)
((= (strcase mode) "MR")
(ea:subst (list alignpt '(72 . 2) '(73 . 3)) entlst)
)
(t entlst)
)
)
)
;;VLA制造函数，没有出错检查
;;修改文字、属性的对齐方式和插入点
(defun ybvl-txtalign (vla-obj pts mode / insertionpt alignpt)
(if (= (length pts) 2)
(setq insertionpt (vlax-3d-point (car pts))
alignpt (vlax-3d-point (cadr pts))
)
(setq insertionpt (vlax-3d-point pts))
)
(cond
((= (strcase mode) "BL")
(vla-put-alignment vla-obj acAlignmentBottomLeft)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "BC")
(vla-put-alignment vla-obj acAlignmentBottomCenter)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "BR")
(vla-put-alignment vla-obj acAlignmentBottomRight)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "MR")
(vla-put-alignment vla-obj acAlignmentMiddleRight)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "MC")
(vla-put-alignment vla-obj acAlignmentMiddleCenter)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "ML")
(vla-put-alignment vla-obj acAlignmentMiddleLeft)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "TR")
(vla-put-alignment vla-obj acAlignmentTopRight)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "TC")
(vla-put-alignment vla-obj acAlignmentTopCenter)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "TL")
(vla-put-alignment vla-obj acAlignmentTopLeft)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "TL")
(vla-put-alignment vla-obj acAlignmentTopLeft)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "R")
(vla-put-alignment vla-obj acAlignmentRight)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "M")
(vla-put-alignment vla-obj acAlignmentMiddle)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "C")
(vla-put-alignment vla-obj acAlignmentCenter)
(vla-put-textalignmentpoint vla-obj insertionpt)
)
((= (strcase mode) "L")
(vla-put-alignment vla-obj acAlignmentLeft)
(vla-put-insertionpoint vla-obj insertionpt)
)
((= (strcase mode) "A")
(vla-put-alignment vla-obj acAlignmentAligned)
(vla-put-textalignmentpoint vla-obj alignpt)
(vla-put-insertionpoint vla-obj insertionpt)
)
((= (strcase mode) "F")
(vla-put-alignment vla-obj acAlignmentFit)
(vla-put-textalignmentpoint vla-obj alignpt)
(vla-put-insertionpoint vla-obj insertionpt)
)
(T (vla-put-insertionpoint vla-obj insertionpt))
)
vla-obj
)
(defun ybvl-addblk (name)
(vla-add (vla-get-blocks *AcDocument*)
(vlax-3d-point '(0. 0. 0.))
name
)
)
(defun ybvl-addsolid (vla-obj pts)
(vla-addsolid
vla-obj
(vlax-3d-point (car pts))
(vlax-3d-point (cadr pts))
(vlax-3d-point (nth 2 pts))
(vlax-3d-point (last pts))
)
)
(defun ybvl-addpline (vla-obj pts)
(vla-addlightweightpolyline
vla-obj
(list->VariantArray pts vlax-vbdouble)
)
)
(defun ybvl-addline (vla-obj pts)
(vla-addline
vla-obj
(vlax-3d-point (car pts))
(vlax-3d-point (cadr pts))
)
)
;; 实体字串插入点高度对齐方式宽度因子旋转角
(defun ybvl-addtext (vla-obj string insertionpt
hight align width rotation
/ txtobj
)
(setq txtobj (vla-addtext
vla-obj
string
(vlax-3d-point
(if (= (length insertionpt) 2)
(CAR insertionpt)
insertionpt
)
)
hight
)
)
(if align
(ybvl-txtalign txtobj insertionpt align)
)
(if rotation
(vla-put-rotation txtobj rotation)
)
(if width
(vla-put-scalefactor txtobj width)
)
txtobj
)
;; 实体插入点模式标签值提示高度对齐方式宽度因子旋转角
(defun ybvl-addatt (vla-obj insertionpt mode tag
string pro hight align width
rotation / attobj
)
(setq attobj (vla-addattribute
vla-obj
hight
(cond
((= mode 1) acAttributeModePreset) ;预制
((= mode 2) acAttributeModeInvisible) ;不可见
((= mode 3) acAttributeModeConstant) ;固定
((= mode 4) acAttributeModeVerify) ;校验
)
pro
(vlax-3d-point
(if (= (length insertionpt) 2)
(car insertionpt)
insertionpt
)
)
tag
string
)
)
(vla-put-StyleName attobj (getvar "textstyle"))
(if width
(vla-put-ScaleFactor attobj width)
)
(if rotation
(vla-put-rotation attobj rotation)
)
(if align
(ybvl-txtalign attobj insertionpt align)
)
attobj
)
;;添加设置当前层
(defun ybvl-addlayer (layname color / lay)
(if (not (setq elay (tblobjname "layer" layname))) ;no
(progn
(setq lay (vla-add (vla-get-layers *AcDocument*) layname))
(if color
(vla-put-color lay color)
)
)
(if (= (type color) 'INT)
(progn
(setq lst (entget elay)
oldlst (assoc 62 lst)
col (abs (cdr oldlst))
)
(if (/= col color)
(setq lst (subst (cons 62 color)
oldlst
lst
)
)
(entmod lst)
)
)
)
)
)
;;新建UCS
(defun ybvl-adducs (ucsname originpt xAxispt yAxispt /)
(setq originpt (vlax-3d-point originpt)
xAxispt (vlax-3d-point xAxispt)
yAxispt (vlax-3d-point yAxispt)
)
(vla-add (vla-get-UserCoordinateSystems *acad*)
originpt
xAxispt
yAxispt
ucsname
)
(princ)
)

(defun ybl-mkpline (pts) 
  (if (entmake (append (list '(0 . "LWPOLYLINE") 
                             '(100 . "AcDbEntity") 
                             '(100 . "AcDbPolyline") 
                             (cons 90 (length pts)) 
 
                       ) 
                       (mapcar '(lambda (x) (cons 10 x)) pts) 
                       '((210 0. 0. 1.)) 
               ) 
      ) 
    (entlast) 
  ) 
) 
(defun ybl-mkcircle (p r) 
  (if (entmake (list '(0 . "CIRCLE") 
                     '(100 . "AcDbEntity") 
                     '(100 . "ACDbCircle") 
                     (cons 10 p) 
                     (cons 40 r) 
                     '(210 0. 0. 1.) 
               ) 
      ) 
    (entlast) 
  ) 
) 
(defun ybl-mkline (p1 p2) 
  (if (entmake (list '(0 . "LINE") 
                     '(100 . "AcDbEntity") 
                     '(100 . "AcDbLine") 
                     (cons 10 p1) 
                     (cons 11 p2) 
                     '(210 0. 0. 1.) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;字串 插入点 高度 宽度因子 
(defun ybl-mktxt (string insertionpt hight width) 
  (if (entmake (list '(0 . "TEXT") 
                     '(100 . "AcDbEntity") 
                     '(100 . "AcDbText") 
                     (cons 1 string) 
                     (cons 10 insertionpt) 
                     (cons 40 hight) 
                     (cons 41 width) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;d70线性32对齐33; p10基点 p13第一点 p14第二点 d1强制长度值 
(defun ybl-MkDimAlign (p1 p2 p3 /) 
  (if (entmake (list '(0 . "DIMENSION") 
                     '(100 . "AcDbEntity") 
                     '(100 . "AcDbDimension") 
                     (cons 10 p3) 
                     '(11 0. 0. 0.) 
                     '(70 . 32) 
                     '(100 . "AcDbAlignedDimension") 
                     (cons 13 p1) 
                     (cons 14 p2) 
                     (cons 50 (angle p1 p2)) 
                     '(100 . "AcDbRotatedDimension") 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;;制造角度标注 
;;(#m_dim '线 '脚1 '脚2 '圆心) 
;;d70=5,37,133,165 
(defun ybl-MkDimAngle (p10 p13 p14 p15 / en000) 
  (if (entmake (list 
                 '(0 . "DIMENSION") 
                 '(100 . "AcDbEntity") 
                 '(100 . "AcDbDimension") 
                 (cons 10 p10)                ;线,注意应在弧线内 
                 '(11 0 0 0)                ;字 
                 '(70 . 5) 
                 '(100 . "AcDb3PointAngularDimension") 
                 (cons 13 p13)                ;脚1 
                 (cons 14 p14)                ;脚2 
                 (cons 15 p15)                ;圆心 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;;========== 
(defun ybl-MKblock (blockname ins-pt) 
;;;做块头 
  (entmake (list 
             '(0 . "BLOCK") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockBegin") 
             (cons 2 blockname) 
             '(70 . 2) 
             (cons 10 ins-pt) 
           ) 
  ) 
) 
(defun ybl-MKENDBLK (lay) 
;;;做块尾 
  (entmake (list 
             '(0 . "ENDBLK") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockEnd") 
           ) 
  ) 
) 
(defun ybl-MkINSERT (bname ins-pt) 
;;;插入图块 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1) 
             (cons 2 bname) 
             (cons 10 ins-pt) 
           ) 
  ) 
) 
(defun ybl-MKATTRIB (txt-str ins-pt txt-ht txt-style lay) 
;;;加入属性 
  (entmake (list 
             '(0 . "ATTRIB") 
             '(100 . "AcDbEntity") 
             (cons 8 lyr) 
             '(100 . "AcDbText") 
             (cons 10 ins-pt) 
             (cons 40 txt-ht) 
             (cons 1 txt-str) 
             (cons 7 txt-style) 
             '(100 . "AcDbAttribute") 
             (cons 2 t-str) 
             '(70 . 0) 
           ) 
  ) 
  (entmake '((0 . "SEQEND"))) 
) 
;;;========== 
;;制造 SOLID ;input : pt1 pt2 pt3 pt4 
(defun ybl-MkSolid (pt1 pt2 pt3 pt4 /) 
  (if (entmake (list 
                 (cons 0 "SOLID") 
                 (cons 10 pt1) 
                 (cons 11 pt2) 
                 (cons 12 pt3) 
                 (cons 13 pt4) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;;画圆环 r1内径r2 外 径 
(defun ybl-MkDonut (p0 r1 r2 / P1 P2 R RR) 
  (setq        r  (/ (+ r1 r2) 2.0) 
        rr (- r2 r1) 
        p1 (polar p0 0 (- r)) 
        p2 (polar p0 0 r) 
  ) 
  (if (entmake (list '(0 . "LWPOLYLINE") 
                     '(100 . "AcDbEntity") 
                     '(67 . 0) 
                     '(100 . "AcDbPolyline") 
                     '(90 . 2) 
                     '(70 . 1) 
                     '(38 . 0.0) 
                     '(39 . 0.0) 
                     (cons 10 p1) 
                     (cons 40 rr) 
                     (cons 41 rr) 
                     '(42 . 1.0) 
                     (cons 10 p2) 
                     (cons 40 rr) 
                     (cons 41 rr) 
                     '(42 . 1.0) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;制造 TRACE ;input : pt1 pt2 pt3 pt4 
(defun ybl-MkTrace (pt1 pt2 pt3 pt4 /) 
  (if (entmake (list 
                 (cons 0 "TRACE") 
                 (cons 10 pt1) 
                 (cons 11 pt2) 
                 (cons 12 pt3) 
                 (cons 13 pt4) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;制造 3DFACE ;   input : pt1 pt2 pt3 pt4 
;; control flag 
(defun ybl-Mk3dface (pt1 pt2 pt3 pt4 flag / en000) ;flag=1248 
  (if (entmake (list 
                 (cons 0 "3DFACE") 
                 (cons 8 lay) 
                 (cons 10 pt1) 
                 (cons 11 pt2) 
                 (cons 12 pt3) 
                 (cons 13 pt4) 
                 (cons 70 flag) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;制造 RAY ; input: 起始 pt1 终止角ANG 
(defun ybl-MkRay (pt1 ang /) 
  (if (entmake (list 
                 (cons 0 "RAY") 
                 '(100 . "AcDbEntity") 
                 '(67 . 0) 
                 '(100 . "AcDbRay") 
                 (cons 8 lay) 
                 (cons 10 pt1) 
                 (cons 11 (list (cos ang) (sin ang))) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;制造 XLINE ; input: 起始 pt1 终止角ANG 
(defun ybl-MkXlin (pt1 ang / en000) 
  (if (entmake (list 
                 (cons 0 "XLINE") 
                 '(100 . "AcDbEntity") 
                 '(67 . 0) 
                 '(100 . "AcDbXline") 
                 (cons 10 pt1) 
                 (cons 11 (list (cos ang) (sin ang))) 
               ) 
      ) 
    (entlast) 
  ) 
) 
;;;============================ 
(defun #m_style        (stynam styw styo styxw styzw / en) 
  ;;造字型 
  (setq e (tblobjname "style" stynam)) 
  (if e 
    (progn 
      (setq en (entget e) 
            en (cy_asubst en 
                          (list 
                            (cons 2 stynam) 
                            (cons 41 styw) 
                            (cons 50 styo) 
                            (cons 3 styxw) 
                            (cons 4 styzw) 
                          ) 
               ) 
      ) 
      (entmod en) 
    ) 
    (progn 
      (setq en (list 
                 '(0 . "STYLE") 
                 '(100 . "AcDbSymbolTableRecord") 
                 '(100 . "AcDbTextStyleTableRecord") 
                 (cons 2 stynam) 
                 '(70 . 0) 
                 '(40 . 0) 
                 (cons 41 styw) 
                 (cons 50 styo) 
                 '(71 . 0) 
                 (cons 3 styxw) 
                 (cons 4 styzw) 
               ) 
      ) 
      (entmake en) 
    ) 
  ) 
) 
;;(#m_style "ddd" 0.8 0 "romans.shx" "dxfs.shx")没有后者为西文romans,romanc,standard, 
;;;;建立字型 
;;;(#m_style "standard" 0.6 (/ pi 12) "romans.shx" "") 
;;;(#m_style "dxfs" 0.7 0 "romans.shx" "dxfs.shx") 
;;;(#m_style "s" 1 0 "romanc.shx" "s.shx") 
;;;(setvar "textstyle" "dxfs") 
(defun ybl-mktxtalign 
       (entity pts mode / ea:subst insertionpt alignpt entlst) 
  (defun ea:subst (item oldlst) 
    (foreach i item 
      (setq oldlst (subst i (assoc (car i) oldlst) oldlst)) 
    ) 
  ) 
  (if (= (length pts) 2) 
    (setq insertionpt (cons 10 (car pts)) 
          alignpt     (cons 11 (cadr pts)) 
    ) 
    (setq alignpt (cons 11 pts)) 
  ) 
  (setq entlst (entget entity)) 
  (entmod 
    (cond 
      ((= (strcase mode) "L") 
       (ea:subst (list (cons 10 pts) '(72 . 0) '(73 . 0)) entlst) 
      ) 
      ((= (strcase mode) "C") 
       (ea:subst (list alignpt '(72 . 1) '(73 . 0)) entlst) 
      ) 
      ((= (strcase mode) "R") 
       (ea:subst (list alignpt '(72 . 2) '(73 . 0)) entlst) 
      ) 
      ((= (strcase mode) "M") 
       (ea:subst (list alignpt '(72 . 4) '(73 . 0)) entlst) 
      ) 
      ((= (strcase mode) "A") 
       (ea:subst (list insertionpt alignpt '(72 . 3) '(73 . 0)) 
                 entlst 
       ) 
      ) 
      ((= (strcase mode) "F") 
       (ea:subst (list insertionpt alignpt '(72 . 5) '(73 . 0)) 
                 entlst 
       ) 
      ) 
      ((= (strcase mode) "BL") 
       (ea:subst (list alignpt '(72 . 0) '(73 . 1)) entlst) 
      ) 
      ((= (strcase mode) "BC") 
       (ea:subst (list alignpt '(72 . 1) '(73 . 1)) entlst) 
      ) 
      ((= (strcase mode) "BR") 
       (ea:subst (list alignpt '(72 . 1) '(73 . 1)) entlst) 
      ) 
      ((= (strcase mode) "ML") 
       (ea:subst (list alignpt '(72 . 0) '(73 . 2)) entlst) 
      ) 
      ((= (strcase mode) "MC") 
       (ea:subst (list alignpt '(72 . 1) '(73 . 2)) entlst) 
      ) 
      ((= (strcase mode) "MR") 
       (ea:subst (list alignpt '(72 . 2) '(73 . 2)) entlst) 
      ) 
      ((= (strcase mode) "TL") 
       (ea:subst (list alignpt '(72 . 0) '(73 . 3)) entlst) 
      ) 
      ((= (strcase mode) "TC") 
       (ea:subst (list alignpt '(72 . 1) '(73 . 3)) entlst) 
      ) 
      ((= (strcase mode) "MR") 
       (ea:subst (list alignpt '(72 . 2) '(73 . 3)) entlst) 
      ) 
      (t entlst) 
    ) 
  ) 
) 
;;VLA制造函数，没有出错检查 
;;修改文字、属性的对齐方式和插入点 
(defun ybvl-txtalign (vla-obj pts mode / insertionpt alignpt) 
  (if (= (length pts) 2) 
    (setq insertionpt (vlax-3d-point (car pts)) 
          alignpt     (vlax-3d-point (cadr pts)) 
    ) 
    (setq insertionpt (vlax-3d-point pts)) 
  ) 
  (cond 
    ((= (strcase mode) "BL") 
     (vla-put-alignment vla-obj acAlignmentBottomLeft) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "BC") 
     (vla-put-alignment vla-obj acAlignmentBottomCenter) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "BR") 
     (vla-put-alignment vla-obj acAlignmentBottomRight) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "MR") 
     (vla-put-alignment vla-obj acAlignmentMiddleRight) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "MC") 
     (vla-put-alignment vla-obj acAlignmentMiddleCenter) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "ML") 
     (vla-put-alignment vla-obj acAlignmentMiddleLeft) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "TR") 
     (vla-put-alignment vla-obj acAlignmentTopRight) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "TC") 
     (vla-put-alignment vla-obj acAlignmentTopCenter) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "TL") 
     (vla-put-alignment vla-obj acAlignmentTopLeft) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "TL") 
     (vla-put-alignment vla-obj acAlignmentTopLeft) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "R") 
     (vla-put-alignment vla-obj acAlignmentRight) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "M") 
     (vla-put-alignment vla-obj acAlignmentMiddle) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "C") 
     (vla-put-alignment vla-obj acAlignmentCenter) 
     (vla-put-textalignmentpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "L") 
     (vla-put-alignment vla-obj acAlignmentLeft) 
     (vla-put-insertionpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "A") 
     (vla-put-alignment vla-obj acAlignmentAligned) 
     (vla-put-textalignmentpoint vla-obj alignpt) 
     (vla-put-insertionpoint vla-obj insertionpt) 
    ) 
    ((= (strcase mode) "F") 
     (vla-put-alignment vla-obj acAlignmentFit) 
     (vla-put-textalignmentpoint vla-obj alignpt) 
     (vla-put-insertionpoint vla-obj insertionpt) 
    ) 
    (T (vla-put-insertionpoint vla-obj insertionpt)) 
  ) 
  vla-obj 
) 
(defun ybvl-addblk (name) 
  (vla-add (vla-get-blocks *AcDocument*) 
           (vlax-3d-point '(0. 0. 0.)) 
           name 
  ) 
) 
(defun ybvl-addsolid (vla-obj pts) 
  (vla-addsolid 
    vla-obj 
    (vlax-3d-point (car pts)) 
    (vlax-3d-point (cadr pts)) 
    (vlax-3d-point (nth 2 pts)) 
    (vlax-3d-point (last pts)) 
  ) 
) 
(defun ybvl-addpline (vla-obj pts) 
  (vla-addlightweightpolyline 
    vla-obj 
    (list->VariantArray pts vlax-vbdouble) 
  ) 
) 
(defun ybvl-addline (vla-obj pts) 
  (vla-addline 
    vla-obj 
    (vlax-3d-point (car pts)) 
    (vlax-3d-point (cadr pts)) 
  ) 
) 
;; 实体 字串 插入点 高度 对齐方式 宽度因子 旋转角 
(defun ybvl-addtext (vla-obj        string           insertionpt 
                     hight        align           width      rotation 
                     /                txtobj 
                    ) 
  (setq        txtobj (vla-addtext 
                 vla-obj 
                 string 
                 (vlax-3d-point 
                   (if (= (length insertionpt) 2) 
                     (CAR insertionpt) 
                     insertionpt 
                   ) 
                 ) 
                 hight 
               ) 
  ) 
  (if align 
    (ybvl-txtalign txtobj insertionpt align) 
  ) 
  (if rotation 
    (vla-put-rotation txtobj rotation) 
  ) 
  (if width 
    (vla-put-scalefactor txtobj width) 
  ) 
  txtobj 
) 
;; 实体 插入点 模式 标签 值 提示 高度 对齐方式 宽度因子 旋转角 
(defun ybvl-addatt (vla-obj   insertionpt          mode            tag 
                    string    pro        hight          align            width 
                    rotation  /                attobj 
                   ) 
  (setq        attobj (vla-addattribute 
                 vla-obj 
                 hight 
                 (cond 
                   ((= mode 1) acAttributeModePreset) ;预制 
                   ((= mode 2) acAttributeModeInvisible) ;不可见 
                   ((= mode 3) acAttributeModeConstant) ;固定 
                   ((= mode 4) acAttributeModeVerify) ;校验 
                 ) 
                 pro 
                 (vlax-3d-point 
                   (if (= (length insertionpt) 2) 
                     (car insertionpt) 
                     insertionpt 
                   ) 
                 ) 
                 tag 
                 string 
               ) 
  ) 
  (vla-put-StyleName attobj (getvar "textstyle")) 
  (if width 
    (vla-put-ScaleFactor attobj width) 
  ) 
  (if rotation 
    (vla-put-rotation attobj rotation) 
  ) 
  (if align 
    (ybvl-txtalign attobj insertionpt align) 
  ) 
  attobj 
) 
;;添加设置当前层 
(defun ybvl-addlayer (layname color / lay) 
  (if (not (setq elay (tblobjname "layer" layname))) ;no 
    (progn 
      (setq lay (vla-add (vla-get-layers *AcDocument*) layname)) 
      (if color 
        (vla-put-color lay color) 
      ) 
    ) 
    (if        (= (type color) 'INT) 
      (progn 
        (setq lst    (entget elay) 
              oldlst (assoc 62 lst) 
              col    (abs (cdr oldlst)) 
        ) 
        (if (/= col color) 
          (setq        lst (subst (cons 62 color) 
                           oldlst 
                           lst 
                    ) 
          ) 
          (entmod lst) 
        ) 
      ) 
    ) 
  ) 
) 
;;新建UCS 
(defun ybvl-adducs (ucsname originpt xAxispt yAxispt /) 
  (setq        originpt (vlax-3d-point originpt) 
        xAxispt         (vlax-3d-point xAxispt) 
        yAxispt         (vlax-3d-point yAxispt) 
  ) 
  (vla-add (vla-get-UserCoordinateSystems *acad*) 
           originpt 
           xAxispt 
           yAxispt 
           ucsname 
  ) 
  (princ) 
)

账号		自动登录	找回密码
密码			立即注册

[原创]：Eachy 工具集 Lisp源码详解

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

本帖被以下淘专辑推荐:

相关帖子

[原创]：Eachy 工具集 Lisp源码 详解

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

本帖被以下淘专辑推荐:

相关帖子

[原创]：Eachy 工具集 Lisp源码详解