判断线型的问题

lucas3 · 发表于 2014-12-22 19:43:24

Free-Lancer 发表于 2014-12-15 09:09
Opendcl 要装 Runtime 在 ODCL 论坛由 8.10 链接下载，命令行输入 opendcl 就可以使用了
简单改写了 ...

Free-Lancer大师，请问这个需要xd::dcl:radioaction 吗？

iLisp · 发表于 2014-12-22 19:52:59

lucas3 发表于 2014-12-22 19:43
Free-Lancer大师，请问这个需要xd::dcl:radioaction 吗？

radio_button 是单选按钮，一个组内只能选择一个

toggle 可选项，可以同时勾选多个

lucas3 · 发表于 2014-12-22 20:40:09

iLisp 发表于 2014-12-22 19:52
radio_button 是单选按钮，一个组内只能选择一个

toggle 可选项，可以同时勾选多个

谢谢指导，那就是需要XD::DCL:ToggleAction

lucas3 · 发表于 2015-1-9 08:29:50

Free-Lancer 发表于 2014-12-15 09:09
Opendcl 要装 Runtime 在 ODCL 论坛由 8.10 链接下载，命令行输入 opendcl 就可以使用了
简单改写了 ...

Free-Lancer大师，您好！您帮我改的那个“圆变螺孔”的程序，我补充了下对话框，现在运行后可以弹出对话框了，但是无法驱动，您的那个XD::DCL:ToggleAction示例不是很完整，下面不知道怎么继续了..................

(defun c:tt (/ ss dcl fn id isBlock isErased isText)
(defun _make
(e l / r pcen dis lst str xk mr cel p1 p2 p3 p4 cir ln1 ln2)
(setq lst '((2.5 "M3" 0.06 1.5)
(3.3 "M4" 0.08 1.5)
(4.2 "M5" 0.1 2.5)
(5.0 "M6" 0.12 3.0)
(6.8 "M8" 0.16 4.0)
(8.5 "M10" 0.2 5.0)
(10.5 "M12" 0.24 6.0)
(12.0 "M14" 0.28 7.0)
(14.0 "M16" 0.32 8.0)
(15.5 "M18" 0.36 9.0)
(17.5 "M20" 0.4 10.0)
)
)
(setq r (vlax-get e 'radius)
pcen (vlax-get e 'center)
)
(mapcar 'set '(str xk mr) (cdr (assoc r lst)))
(setq
cel (if (eq (car (setq lt (vlax-get e "linetype"))
"ByLayer"
)
)
(vlax-get
(vla-item (fy:aclayers) (vlax-get e "layer"))
"linetype"
)
(car lt)
)
)
(setq dis (* r 1.1)
p1 (polar pcen 0. dis)
p2 (polar pcen _pi2 dis)
p3 (polar pcen pi dis)
p4 (polar pcen (- _pi2) dis)
)
(if isBlock
(setq space (vlax-invoke (fy:acblocks) 'add pcen "*"))
(setq space (fy:acms))
)
(setq cir (vlax-invoke space 'addcircle pcen r)
arc (vlax-invoke space 'addarc pcen mr 4.71239 3.14159)
ln1 (vlax-invoke space 'addline p1 p3)
ln2 (vlax-invoke space 'addline p2 p4)
)
(mapcar '(lambda (x)
(vlax-put (car x) 'layer "screw")
(vlax-put (car x) 'color (cadr x))
(vlax-put (car x) "linetype" (caddr x))
(vlax-put (car x) "linetypescale" xk)
)
(list (list cir 33 cel)
(list arc 3 cel)
(list ln1 1 "center")
(list ln2 1 "center")
)
)
(if isText
(progn
(setq txt (vlax-invoke space 'AddText str pcen (* mr 0.4)))
(vla-put-alignment txt acAlignmentTopCenter)
(vla-put-textalignmentpoint
txt
(vlax-3d-point (polar pcen (- _pi2) (* mr 0.17)))
)
)
)
(if isBlock
(vlax-invoke
(fy:acspace)
'insertblock
pcen
(vla-get-name space)
1.
1.
1.
0.
)
)
)
(setq dcl '("screw:dialog{"
"label = \"参数设置\";"
" :toggle{ key = \"isErased\"; label = \"删除原线条\";}"
" :toggle { key = \"isText\"; label = \"显示文字\";}"
" :toggle { key = \"isBlock\"; label = \"生成块\";}"
" ok_cancel;"
"}"
)
fn (xd::dcl:make dcl)
id (xd::dcl:load fn "screw")
)
(xd::Dcl:toggleaction
'("isErased" "isText" "isBlock");_key 列表
'status;_记录勾选项的变量，做全局变量时下次有默认值
);_设置 Toggle 并定义 Action
(xd::dcl:start id fn)
(fy:begin)
(if (setq ss (ssget '((0 . "circle"))))
(progn
(if (not (tblsearch "style" "txt"))
(command ".style" "txt" "txt.shx,gbcbig.shx"
0.0 1.0 0.0 "n"
"n" "n"
)
)
(if (not (tblsearch "ltype" "hidden"))
(vla-load (fy:acltypes) "hidden" "acadiso.lin")
)
(if (not (tblsearch "ltype" "center"))
(vla-load (fy:acltypes) "center" "acadiso.lin")
)
(mapcar '(lambda (x) (_make x)) (fy:cset->objs))
(if isErased (command ".erase" ss ""))
)
)
(princ)
)

(defun c:tt (/ ss dcl fn id isBlock isErased isText) 
  (defun _make 
         (e l / r pcen dis lst str xk mr cel p1 p2 p3 p4 cir ln1 ln2) 
    (setq lst '((2.5 "M3" 0.06 1.5) 
                (3.3 "M4" 0.08 1.5) 
                (4.2 "M5" 0.1 2.5) 
                (5.0 "M6" 0.12 3.0) 
                (6.8 "M8" 0.16 4.0) 
                (8.5 "M10" 0.2 5.0) 
                (10.5 "M12" 0.24 6.0) 
                (12.0 "M14" 0.28 7.0) 
                (14.0 "M16" 0.32 8.0) 
                (15.5 "M18" 0.36 9.0) 
                (17.5 "M20" 0.4 10.0) 
               ) 
    ) 
    (setq r    (vlax-get e 'radius) 
          pcen (vlax-get e 'center) 
    ) 
    (mapcar 'set '(str xk mr) (cdr (assoc r lst))) 
    (setq 
      cel (if (eq (car (setq lt (vlax-get e "linetype")) 
                       "ByLayer" 
                  ) 
              ) 
            (vlax-get 
              (vla-item (fy:aclayers) (vlax-get e "layer")) 
              "linetype" 
            ) 
            (car lt) 
          ) 
    ) 
    (setq dis (* r 1.1) 
          p1  (polar pcen 0. dis) 
          p2  (polar pcen _pi2 dis) 
          p3  (polar pcen pi dis) 
          p4  (polar pcen (- _pi2) dis) 
    ) 
    (if        isBlock 
      (setq space (vlax-invoke (fy:acblocks) 'add pcen "*")) 
      (setq space (fy:acms)) 
    ) 
    (setq cir (vlax-invoke space 'addcircle pcen r) 
          arc (vlax-invoke space 'addarc pcen mr 4.71239 3.14159) 
          ln1 (vlax-invoke space 'addline p1 p3) 
          ln2 (vlax-invoke space 'addline p2 p4) 
    ) 
    (mapcar '(lambda (x) 
               (vlax-put (car x) 'layer "screw") 
               (vlax-put (car x) 'color (cadr x)) 
               (vlax-put (car x) "linetype" (caddr x)) 
               (vlax-put (car x) "linetypescale" xk) 
             ) 
            (list (list cir 33 cel) 
                  (list arc 3 cel) 
                  (list ln1 1 "center") 
                  (list ln2 1 "center") 
            ) 
    ) 
    (if        isText 
      (progn 
        (setq txt (vlax-invoke space 'AddText str pcen (* mr 0.4))) 
        (vla-put-alignment txt acAlignmentTopCenter) 
        (vla-put-textalignmentpoint 
          txt 
          (vlax-3d-point (polar pcen (- _pi2) (* mr 0.17))) 
        ) 
      ) 
    ) 
    (if        isBlock 
      (vlax-invoke 
        (fy:acspace) 
        'insertblock 
        pcen 
        (vla-get-name space) 
        1. 
        1. 
        1. 
        0. 
      ) 
    ) 
  ) 
  (setq        dcl '("screw:dialog{" 
              "label = \"参数设置\";" 
              " :toggle{ key = \"isErased\"; label = \"删除原线条\";}" 
              " :toggle { key = \"isText\"; label = \"显示文字\";}" 
              " :toggle { key = \"isBlock\"; label = \"生成块\";}" 
              " ok_cancel;" 
              "}" 
             ) 
        fn  (xd::dcl:make dcl) 
        id   (xd::dcl:load fn "screw") 
  ) 
    (xd::Dcl:toggleaction 
    '("isErased" "isText" "isBlock");_key 列表 
    'status;_记录 勾选项 的变量，做全局变量时下次有默认值 
  );_设置 Toggle  并定义 Action 
  (xd::dcl:start id fn) 
  (fy:begin) 
  (if (setq ss (ssget '((0 . "circle")))) 
    (progn 
      (if (not (tblsearch "style" "txt")) 
        (command ".style"    "txt"         "txt.shx,gbcbig.shx" 
                 0.0             1.0         0.0             "n" 
                 "n"             "n" 
                ) 
      ) 
      (if (not (tblsearch "ltype" "hidden")) 
        (vla-load (fy:acltypes) "hidden" "acadiso.lin") 
      ) 
      (if (not (tblsearch "ltype" "center")) 
        (vla-load (fy:acltypes) "center" "acadiso.lin") 
      ) 
      (mapcar '(lambda (x) (_make x)) (fy:cset->objs)) 
      (if isErased (command ".erase" ss "")) 
    ) 
  ) 
  (princ) 
)

Free-Lancer · 发表于 2015-1-9 09:08:30

lucas3 发表于 2015-1-9 08:29
Free-Lancer大师，您好！您帮我改的那个“圆变螺孔”的程序，我补充了下对话框，现在运行后可以弹出对 ...

还没有搞好啊!

lucas3 · 发表于 2015-1-9 09:27:06

Free-Lancer 发表于 2015-1-9 09:08
还没有搞好啊!

是啊，大师，汗颜啊呜呜...,

Free-Lancer · 发表于 2015-1-9 09:58:46

lucas3 发表于 2015-1-9 09:27
是啊，大师，汗颜啊呜呜...,

(defun c:tt (/ ss dcl fn id klst)
(defun _make (e l / r pcen dis lst str xk mr cel p1 p2 p3 p4 cir ln1
ln2)
(setq lst '((2.5 "M3" 0.06 1.5)
(3.3 "M4" 0.08 1.5)
(4.2 "M5" 0.1 2.5)
(5.0 "M6" 0.12 3.0)
(6.8 "M8" 0.16 4.0)
(8.5 "M10" 0.2 5.0)
(10.5 "M12" 0.24 6.0)
(12.0 "M14" 0.28 7.0)
(14.0 "M16" 0.32 8.0)
(15.5 "M18" 0.36 9.0)
(17.5 "M20" 0.4 10.0)
)
)
(setq r (vlax-get e 'radius)
pcen (vlax-get e 'center)
)
(mapcar 'set '(str xk mr) (cdr (assoc r lst)))
(setq
cel (if (eq (car (setq lt (vlax-get e "linetype"))
"ByLayer"
)
)
(vlax-get
(vla-item (fy:aclayers) (vlax-get e "layer"))
"linetype"
)
(car lt)
)
)
(setq dis (* r 1.1)
p1 (polar pcen 0. dis)
p2 (polar pcen _pi2 dis)
p3 (polar pcen pi dis)
p4 (polar pcen (- _pi2) dis)
)
(if (member "isBlock" slst)
(setq space (vlax-invoke (fy:acblocks) 'add pcen "*"))
(setq space (fy:acms))
)
(setq cir (vlax-invoke space 'addcircle pcen r)
arc (vlax-invoke space 'addarc pcen mr 4.71239 3.14159)
ln1 (vlax-invoke space 'addline p1 p3)
ln2 (vlax-invoke space 'addline p2 p4)
)
(mapcar '(lambda (x)
(vlax-put (car x) 'layer "screw")
(vlax-put (car x) 'color (cadr x))
(vlax-put (car x) "linetype" (caddr x))
(vlax-put (car x) "linetypescale" xk)
)
(list (list cir 33 cel)
(list arc 3 cel)
(list ln1 1 "center")
(list ln2 1 "center")
)
)
(if (member "isText" slst)
(progn
(setq txt (vlax-invoke space 'AddText str pcen (* mr 0.4)))
(vla-put-alignment txt acAlignmentTopCenter)
(vla-put-textalignmentpoint
txt
(vlax-3d-point (polar pcen (- _pi2) (* mr 0.17)))
)
)
)
(if (member "isBlock" slst)
(vlax-invoke
(fy:acspace)
'insertblock
pcen
(vla-get-name space)
1.
1.
1.
0.
)
)
)
(if slst (setq slst '("isErased" "isText" "isBlock")))
(setq dcl '("screw:dialog{"
"label = \"参数设置\";"
" :toggle{ key = \"isErased\"; label = \"删除原线条\";}"
" :toggle { key = \"isText\"; label = \"显示文字\";}"
" :toggle { key = \"isBlock\"; label = \"生成块\";}"
" ok_cancel;"
"}"
)
klst '("isErased" "isText" "isBlock")
fn (xd::dcl:make dcl)
id (xd::dcl:load fn "screw")
)
(xd::Dcl:toggleaction
klst ;_key 列表
'slst ;_记录勾选项的变量，做全局变量时下次有默认值
nil
) ;_设置 Toggle 并定义 Action
(xd::dcl:start id fn)
(fy:begin)
(if (setq ss (ssget '((0 . "circle"))))
(progn
(if (not (tblsearch "style" "txt"))
(command ".style" "txt" "txt.shx,gbcbig.shx"
0.0 1.0 0.0 "n"
"n" "n"
)
)
(if (not (tblsearch "ltype" "hidden"))
(vla-load (fy:acltypes) "hidden" "acadiso.lin")
)
(if (not (tblsearch "ltype" "center"))
(vla-load (fy:acltypes) "center" "acadiso.lin")
)
(mapcar '(lambda (x) (_make x)) (fy:cset->objs))
(if (member "isErased" slst)
(command ".erase" ss "")
)
)
)
(princ)
)

(defun c:tt (/ ss dcl fn id klst) 
  (defun _make (e l / r        pcen dis lst str xk mr cel p1 p2 p3 p4 cir ln1 
                ln2) 
    (setq lst '((2.5 "M3" 0.06 1.5) 
                (3.3 "M4" 0.08 1.5) 
                (4.2 "M5" 0.1 2.5) 
                (5.0 "M6" 0.12 3.0) 
                (6.8 "M8" 0.16 4.0) 
                (8.5 "M10" 0.2 5.0) 
                (10.5 "M12" 0.24 6.0) 
                (12.0 "M14" 0.28 7.0) 
                (14.0 "M16" 0.32 8.0) 
                (15.5 "M18" 0.36 9.0) 
                (17.5 "M20" 0.4 10.0) 
               ) 
    ) 
    (setq r    (vlax-get e 'radius) 
          pcen (vlax-get e 'center) 
    ) 
    (mapcar 'set '(str xk mr) (cdr (assoc r lst))) 
    (setq 
      cel (if (eq (car (setq lt (vlax-get e "linetype")) 
                       "ByLayer" 
                  ) 
              ) 
            (vlax-get 
              (vla-item (fy:aclayers) (vlax-get e "layer")) 
              "linetype" 
            ) 
            (car lt) 
          ) 
    ) 
    (setq dis (* r 1.1) 
          p1  (polar pcen 0. dis) 
          p2  (polar pcen _pi2 dis) 
          p3  (polar pcen pi dis) 
          p4  (polar pcen (- _pi2) dis) 
    ) 
    (if        (member "isBlock" slst) 
      (setq space (vlax-invoke (fy:acblocks) 'add pcen "*")) 
      (setq space (fy:acms)) 
    ) 
    (setq cir (vlax-invoke space 'addcircle pcen r) 
          arc (vlax-invoke space 'addarc pcen mr 4.71239 3.14159) 
          ln1 (vlax-invoke space 'addline p1 p3) 
          ln2 (vlax-invoke space 'addline p2 p4) 
    ) 
    (mapcar '(lambda (x) 
               (vlax-put (car x) 'layer "screw") 
               (vlax-put (car x) 'color (cadr x)) 
               (vlax-put (car x) "linetype" (caddr x)) 
               (vlax-put (car x) "linetypescale" xk) 
             ) 
            (list (list cir 33 cel) 
                  (list arc 3 cel) 
                  (list ln1 1 "center") 
                  (list ln2 1 "center") 
            ) 
    ) 
    (if        (member "isText" slst) 
      (progn 
        (setq txt (vlax-invoke space 'AddText str pcen (* mr 0.4))) 
        (vla-put-alignment txt acAlignmentTopCenter) 
        (vla-put-textalignmentpoint 
          txt 
          (vlax-3d-point (polar pcen (- _pi2) (* mr 0.17))) 
        ) 
      ) 
    ) 
    (if        (member "isBlock" slst) 
      (vlax-invoke 
        (fy:acspace) 
        'insertblock 
        pcen 
        (vla-get-name space) 
        1. 
        1. 
        1. 
        0. 
      ) 
    ) 
  ) 
  (if slst (setq        slst '("isErased" "isText" "isBlock"))) 
  (setq        dcl  '("screw:dialog{" 
               "label = \"参数设置\";" 
               " :toggle{ key = \"isErased\"; label = \"删除原线条\";}" 
               " :toggle { key = \"isText\"; label = \"显示文字\";}" 
               " :toggle { key = \"isBlock\"; label = \"生成块\";}" 
               " ok_cancel;" 
               "}" 
              ) 
        klst '("isErased" "isText" "isBlock") 
        fn   (xd::dcl:make dcl) 
        id   (xd::dcl:load fn "screw") 
  ) 
  (xd::Dcl:toggleaction 
    klst ;_key 列表 
    'slst ;_记录 勾选项 的变量，做全局变量时下次有默认值 
    nil 
  ) ;_设置 Toggle  并定义 Action 
  (xd::dcl:start id fn) 
  (fy:begin) 
  (if (setq ss (ssget '((0 . "circle")))) 
    (progn 
      (if (not (tblsearch "style" "txt")) 
        (command ".style"    "txt"         "txt.shx,gbcbig.shx" 
                 0.0             1.0         0.0             "n" 
                 "n"             "n" 
                ) 
      ) 
      (if (not (tblsearch "ltype" "hidden")) 
        (vla-load (fy:acltypes) "hidden" "acadiso.lin") 
      ) 
      (if (not (tblsearch "ltype" "center")) 
        (vla-load (fy:acltypes) "center" "acadiso.lin") 
      ) 
      (mapcar '(lambda (x) (_make x)) (fy:cset->objs)) 
      (if (member "isErased" slst) 
        (command ".erase" ss "") 
      ) 
    ) 
  ) 
  (princ) 
)

另外的 XD:: ToggleAction 函数

(defun XD::DCL:ToggleAction
(_$klst _$symL _$callbackL / _sToggleAction)
(defun _sToggleAction (_$key _$symL _$callbackL)
(action_tile
_$key
(strcat "(if (= $value \"0\")"
"(setq "
(vl-symbol-name _$symL)
"(vl-remove $key "
(vl-symbol-name _$symL)
"))(if (not (member $key "
(vl-symbol-name _$symL)
"))(setq "
(vl-symbol-name _$symL)
"(cons $key "
(vl-symbol-name _$symL)
"))))"
(if _$callbackL
(strcat "(" _$callbackL ")")
""
)
)
)
)
(XD::DCL:ToggleInit _$klst _$symL)
(if (listp _$klst)
(while _$klst
(_sToggleAction (car _$klst) _$symL (car _$callbackL))
(setq _$klst (cdr _$klst)
_$callbackL (cdr _$callbackL)
)
)
(_sToggleAction _$klst _$symL _$callbackL)
)
)

(defun XD::DCL:ToggleAction 
       (_$klst _$symL _$callbackL / _sToggleAction) 
  (defun _sToggleAction        (_$key _$symL _$callbackL) 
    (action_tile 
      _$key 
      (strcat "(if (= $value \"0\")" 
              "(setq " 
              (vl-symbol-name _$symL) 
              "(vl-remove $key " 
              (vl-symbol-name _$symL) 
              "))(if (not (member $key " 
              (vl-symbol-name _$symL) 
              "))(setq " 
              (vl-symbol-name _$symL) 
              "(cons $key " 
              (vl-symbol-name _$symL) 
              "))))" 
              (if _$callbackL 
                (strcat "(" _$callbackL ")") 
                "" 
              ) 
      ) 
    ) 
  ) 
  (XD::DCL:ToggleInit _$klst _$symL) 
  (if (listp _$klst) 
    (while _$klst 
      (_sToggleAction (car _$klst) _$symL (car _$callbackL)) 
      (setq _$klst        (cdr _$klst) 
            _$callbackL        (cdr _$callbackL) 
      ) 
    ) 
    (_sToggleAction _$klst _$symL _$callbackL) 
  ) 
)

lucas3 · 发表于 2015-1-9 10:58:09

Free-Lancer 发表于 2015-1-9 09:58
另外的 XD:: ToggleAction 函数

感谢大师再次相助！！！大师，XD::DCL:ToggleInithan函数在哪儿呢？

Free-Lancer · 发表于 2015-1-9 11:42:07

lucas3 发表于 2015-1-9 10:58
感谢大师再次相助！！！大师，XD:CL:ToggleInithan函数在哪儿呢？

设置 toggle 控件
_$klst ---- 控件名或控件名列表
_$symL ---- 值为控件名或控件名列表的变量名
含有该控件的为勾选，否则不选
|;
(defun XD::DCL:ToggleInit (_$klst _$symL)
(if (listp _$klst)
(mapcar '(lambda (x)
(if (and _$symL (member x (vl-symbol-value _$symL)))
(set_tile x "1")
(set_tile x "0")
)
)
_$klst
)
(set_tile _$klst
(if (and _$syml (vl-symbol-value _$symL))
"1"
"0"
)
)
)
)

lucas3 · 发表于 2015-1-9 13:32:34

Free-Lancer 发表于 2015-1-9 11:42

谢谢大师，可是程序仍然不能正常执行，选择圆后总是显示Error: 参数太少

iLisp · 发表于 2015-1-9 14:21:24

lucas3 发表于 2015-1-9 13:32
谢谢大师，可是程序仍然不能正常执行，选择圆后总是显示Error: 参数太少

目测 _make 子函数多了个 l 参数，去掉试试

lucas3 · 发表于 2015-1-9 17:28:51

iLisp 发表于 2015-1-9 14:21
目测 _make 子函数多了个 l 参数，去掉试试

不行哟，去掉显示参数太多，另外，还有问题就是弹出对话框后，不点确定，直接点取消，程序没有结束，而是仍然要求选择对象

Free-Lancer · 发表于 2015-1-9 17:32:25

lucas3 发表于 2015-1-9 17:28
不行哟，去掉显示参数太多，另外，还有问题就是弹出对话框后，不点确定，直接点取消，程序没有结束，而 ...

(defun c:tt (/ ss dcl fn id klst)
(defun _make
(e / r pcen dis lst str xk mr cel p1 p2 p3 p4 cir ln1 ln2)
(setq lst '((2.5 "M3" 0.06 1.5)
(3.3 "M4" 0.08 1.5)
(4.2 "M5" 0.1 2.5)
(5.0 "M6" 0.12 3.0)
(6.8 "M8" 0.16 4.0)
(8.5 "M10" 0.2 5.0)
(10.5 "M12" 0.24 6.0)
(12.0 "M14" 0.28 7.0)
(14.0 "M16" 0.32 8.0)
(15.5 "M18" 0.36 9.0)
(17.5 "M20" 0.4 10.0)
)
)
(setq r (vlax-get e 'radius)
pcen (vlax-get e 'center)
)
(mapcar 'set '(str xk mr) (cdr (assoc r lst)))
(setq cel (if (eq (setq lt (vlax-get e "linetype"))
"ByLayer"
)
(vlax-get
(vla-item (fy:aclayers) (vlax-get e "layer"))
"linetype"
)
lt
)
)
(setq dis (* r 1.1)
p1 (polar pcen 0. dis)
p2 (polar pcen _pi2 dis)
p3 (polar pcen pi dis)
p4 (polar pcen (- _pi2) dis)
)
(if (member "isBlock" slst)
(setq space (vla-add (fy:acblocks) (vlax-3d-point pcen) "*U"))
(setq space (fy:acms))
)
(setq cir (vlax-invoke space 'addcircle pcen r)
arc (vlax-invoke space 'addarc pcen mr 4.71239 3.14159)
ln1 (vlax-invoke space 'addline p1 p3)
ln2 (vlax-invoke space 'addline p2 p4)
)
(mapcar '(lambda (x)
(vlax-put (car x) 'layer "screw")
(vlax-put (car x) 'color (cadr x))
(vlax-put (car x) "linetype" (caddr x))
(vlax-put (car x) "linetypescale" xk)
)
(list (list cir 33 cel)
(list arc 3 cel)
(list ln1 1 "center")
(list ln2 1 "center")
)
)
(if (member "isText" slst)
(progn
(setq txt (vlax-invoke space 'AddText str pcen (* mr 0.4)))
(vla-put-alignment txt acAlignmentTopCenter)
(vla-put-textalignmentpoint
txt
(vlax-3d-point (polar pcen (- _pi2) (* mr 0.17)))
)
)
)
(if (member "isBlock" slst)
(vlax-invoke
(fy:acspace)
'insertblock
pcen
(vla-get-name space)
1.
1.
1.
0.
)
)
)
(if slst
(setq slst '("isErased" "isText" "isBlock"))
)
(setq dcl '("screw:dialog{"
"label = \"参数设置\";"
" :toggle{ key = \"isErased\"; label = \"删除原线条\";}"
" :toggle { key = \"isText\"; label = \"显示文字\";}"
" :toggle { key = \"isBlock\"; label = \"生成块\";}"
" ok_cancel;"
"}"
)
klst '("isErased" "isText" "isBlock")
fn (xd::dcl:make dcl)
id (xd::dcl:load fn "screw")
)
(xd::Dcl:toggleaction
klst ;_key 列表
'slst ;_记录勾选项的变量，做全局变量时下次有默认值
nil
) ;_设置 Toggle 并定义 Action
(xd::dcl:start id fn)
(fy:begin)
(if (setq ss (ssget '((0 . "circle"))))
(progn
(if (not (tblsearch "style" "txt"))
(command ".style" "txt" "txt.shx,gbcbig.shx"
0.0 1.0 0.0 "n"
"n" "n"
)
)
(if (not (tblsearch "ltype" "hidden"))
(vla-load (fy:acltypes) "hidden" "acadiso.lin")
)
(if (not (tblsearch "ltype" "center"))
(vla-load (fy:acltypes) "center" "acadiso.lin")
)
(mapcar '(lambda (x) (_make x)) (fy:cset->objs))
(if (member "isErased" slst)
(command ".erase" ss "")
)
)
)
(princ)
)

(defun c:tt (/ ss dcl fn id klst) 
  (defun _make 
         (e / r pcen dis lst str xk mr cel p1 p2 p3 p4 cir ln1 ln2) 
    (setq lst '((2.5 "M3" 0.06 1.5) 
                (3.3 "M4" 0.08 1.5) 
                (4.2 "M5" 0.1 2.5) 
                (5.0 "M6" 0.12 3.0) 
                (6.8 "M8" 0.16 4.0) 
                (8.5 "M10" 0.2 5.0) 
                (10.5 "M12" 0.24 6.0) 
                (12.0 "M14" 0.28 7.0) 
                (14.0 "M16" 0.32 8.0) 
                (15.5 "M18" 0.36 9.0) 
                (17.5 "M20" 0.4 10.0) 
               ) 
    ) 
    (setq r    (vlax-get e 'radius) 
          pcen (vlax-get e 'center) 
    ) 
    (mapcar 'set '(str xk mr) (cdr (assoc r lst))) 
    (setq cel (if (eq (setq lt (vlax-get e "linetype")) 
 
                      "ByLayer" 
                  ) 
                (vlax-get 
                  (vla-item (fy:aclayers) (vlax-get e "layer")) 
                  "linetype" 
                ) 
                lt 
              ) 
    ) 
    (setq dis (* r 1.1) 
          p1  (polar pcen 0. dis) 
          p2  (polar pcen _pi2 dis) 
          p3  (polar pcen pi dis) 
          p4  (polar pcen (- _pi2) dis) 
    ) 
    (if        (member "isBlock" slst) 
      (setq space (vla-add (fy:acblocks) (vlax-3d-point pcen) "*U")) 
      (setq space (fy:acms)) 
    ) 
    (setq cir (vlax-invoke space 'addcircle pcen r) 
          arc (vlax-invoke space 'addarc pcen mr 4.71239 3.14159) 
          ln1 (vlax-invoke space 'addline p1 p3) 
          ln2 (vlax-invoke space 'addline p2 p4) 
    ) 
    (mapcar '(lambda (x) 
               (vlax-put (car x) 'layer "screw") 
               (vlax-put (car x) 'color (cadr x)) 
               (vlax-put (car x) "linetype" (caddr x)) 
               (vlax-put (car x) "linetypescale" xk) 
             ) 
            (list (list cir 33 cel) 
                  (list arc 3 cel) 
                  (list ln1 1 "center") 
                  (list ln2 1 "center") 
            ) 
    ) 
    (if        (member "isText" slst) 
      (progn 
        (setq txt (vlax-invoke space 'AddText str pcen (* mr 0.4))) 
        (vla-put-alignment txt acAlignmentTopCenter) 
        (vla-put-textalignmentpoint 
          txt 
          (vlax-3d-point (polar pcen (- _pi2) (* mr 0.17))) 
        ) 
      ) 
    ) 
    (if        (member "isBlock" slst) 
      (vlax-invoke 
        (fy:acspace) 
        'insertblock 
        pcen 
        (vla-get-name space) 
        1. 
        1. 
        1. 
        0. 
      ) 
    ) 
  ) 
  (if slst 
    (setq slst '("isErased" "isText" "isBlock")) 
  ) 
  (setq        dcl  '("screw:dialog{" 
               "label = \"参数设置\";" 
               " :toggle{ key = \"isErased\"; label = \"删除原线条\";}" 
               " :toggle { key = \"isText\"; label = \"显示文字\";}" 
               " :toggle { key = \"isBlock\"; label = \"生成块\";}" 
               " ok_cancel;" 
               "}" 
              ) 
        klst '("isErased" "isText" "isBlock") 
        fn   (xd::dcl:make dcl) 
        id   (xd::dcl:load fn "screw") 
  ) 
  (xd::Dcl:toggleaction 
    klst ;_key 列表 
    'slst ;_记录 勾选项 的变量，做全局变量时下次有默认值 
    nil 
  ) ;_设置 Toggle  并定义 Action 
  (xd::dcl:start id fn) 
  (fy:begin) 
  (if (setq ss (ssget '((0 . "circle")))) 
    (progn 
      (if (not (tblsearch "style" "txt")) 
        (command ".style"    "txt"         "txt.shx,gbcbig.shx" 
                 0.0             1.0         0.0             "n" 
                 "n"             "n" 
                ) 
      ) 
      (if (not (tblsearch "ltype" "hidden")) 
        (vla-load (fy:acltypes) "hidden" "acadiso.lin") 
      ) 
      (if (not (tblsearch "ltype" "center")) 
        (vla-load (fy:acltypes) "center" "acadiso.lin") 
      ) 
      (mapcar '(lambda (x) (_make x)) (fy:cset->objs)) 
      (if (member "isErased" slst) 
        (command ".erase" ss "") 
      ) 
    ) 
  ) 
  (princ) 
)

Free-Lancer · 发表于 2015-1-9 17:36:54

lucas3 发表于 2015-1-9 17:28
不行哟，去掉显示参数太多，另外，还有问题就是弹出对话框后，不点确定，直接点取消，程序没有结束，而 ...

自己改一下吧

  (fy:begin)
  (if (and (= (xd::dcl:start id fn) 1)
   (setq ss (ssget '((0 . "circle"))))
   )

lucas3 · 发表于 2015-1-9 18:20:19

Free-Lancer 发表于 2015-1-9 17:36
自己改一下吧

(fy:begin)

大师，重新使用28楼的程序，并将29楼处的替换掉，问题还存在，还是参数太少，点取消还是要选择对象

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

[已解决] 判断线型的问题

点评

点评

点评

点评

点评

点评

评分

点评

评分

点评

点评

点评

点评