求修改一个程序（添加dialog ）

lucas3 · 发表于 2014-9-9 09:12:32

本帖最后由 lucas3 于 2015-4-17 16:44 编辑

原贴地址在：http://bbs.mjtd.com/thread-111293-1-1.html
Free-Lancer大师，有一个程序想加一个对话框，能帮我修改下吗？万分感谢！
源程序如下: 原程序来之于q3_2006(感谢！）

(defun mkarc (p w f / p1 p2)
(cond
((= f 3) (setq p1 (mapcar '- p (list (* -0.25 w) (* 0.5 (abs w)) ))
p2 (mapcar '- p (list 0 (abs w) ))
)
(vl-cmdf "arc" p p1 p2)
)
((= f 2) (setq p1 (mapcar '+ p (list (* 0.25 w) (* -0.5 (abs w)) ))
p2 (mapcar '+ p (list (* 0.25 w) (* 0.5 (abs w)) ))
)
(vl-cmdf "arc" p1 p p2)
)
((= f 1) (setq p1 (mapcar '+ p (list (* 0.25 w) (* 0.5 (abs w)) ))
p2 (mapcar '+ p (list 0 (abs w) ))
)
(vl-cmdf "arc" p p1 p2)
)
)
(entlast)
)
(defun mat:rotation ( cen ang / c s x y)
(setq c (cos ang) s (sin ang))
(setq x (car cen) y (cadr cen))
(list
(list c (- s) 0. (- x (- (* c x) (* s y))))
(list s c 0. (- y (+ (* s x) (* c y))))
'(0. 0. 1. 0.)
'(0. 0. 0. 1.)
)
)
(defun HH:PtFirstAngle (obj pt)
(setq param (vlax-curve-getParamAtPoint obj pt))
(angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param)))
)
(defun c:tt ( / aa a an d d1 d2 e f i l odlst p1 p2 pr q w x y)
(setq odlst (mapcar 'getvar '("cmdecho" "osmode" "peditaccept")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 544))
(setq w (getreal "\n输入圆弧宽度:") ;负值反向
d (getreal "\n输入圆弧间距:")
a (car (entsel "\n选择曲线:"))
p1 (getpoint "\n起点:")
p2 (getpoint "\n终点:")
l (list p1 p2)
l (vl-sort l '(lambda (x y) (< (vlax-curve-getDistAtPoint a x) (vlax-curve-getDistAtPoint a y)) ) )
p1 (car l)
p2 (cadr l)
d1 (vlax-curve-getDistAtPoint a p1)
d2 (vlax-curve-getDistAtPoint a p2)
i -1
l nil
)
(while (< (setq pr (+ (* (setq i (1+ i)) d) d1)) d2)
(setq l (cons (vlax-curve-getPointAtDist a pr) l))
)
(setq l (reverse l))
(setvar "osmode" 0)
(princ "\n[1上,2中,3下]")
(setq aa (grread))
(cond
((= (cadr aa) 49) (setq f 1) )
((= (cadr aa) 50) (setq f 2) )
((= (cadr aa) 51) (setq f 3) )
)
(mapcar '(lambda(x)
(setq an (HH:PtFirstAngle a x) q (mat:rotation x an) e (mkarc x w f))
(vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix q))
) l)
(mapcar 'setvar '("cmdecho" "osmode") odlst)
)

(defun mkarc (p w f / p1 p2) 
(cond 
  ((= f 3) (setq p1 (mapcar '- p (list (* -0.25 w) (* 0.5 (abs w)) )) 
  p2 (mapcar '- p (list 0 (abs w) )) 
) 
(vl-cmdf "arc" p p1 p2) 
) 
  ((= f 2) (setq p1 (mapcar '+ p (list (* 0.25 w) (* -0.5 (abs w)) )) 
  p2 (mapcar '+ p (list (* 0.25 w) (* 0.5 (abs w)) )) 
) 
(vl-cmdf "arc" p1 p p2) 
) 
  ((= f 1) (setq p1 (mapcar '+ p (list (* 0.25 w) (* 0.5 (abs w)) )) 
  p2 (mapcar '+ p (list 0 (abs w) )) 
) 
(vl-cmdf "arc" p p1 p2) 
) 
) 
(entlast) 
) 
(defun mat:rotation ( cen ang / c s x y) 
  (setq c (cos ang) s (sin ang)) 
  (setq x (car cen) y (cadr cen)) 
  (list 
    (list c (- s) 0. (- x (- (* c x) (* s y)))) 
    (list s    c  0. (- y (+ (* s x) (* c y)))) 
    '(0. 0. 1. 0.) 
    '(0. 0. 0. 1.) 
  ) 
) 
(defun HH:PtFirstAngle (obj pt) 
  (setq param (vlax-curve-getParamAtPoint obj pt)) 
  (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param))) 
) 
(defun c:tt ( / aa a an d d1 d2 e f i l odlst p1 p2 pr q w x y) 
(setq odlst (mapcar 'getvar '("cmdecho" "osmode" "peditaccept"))) 
(mapcar 'setvar '("cmdecho" "osmode") '(0 544)) 
(setq w (getreal "\n输入圆弧宽度:") ;负值反向 
  d (getreal "\n输入圆弧间距:") 
  a (car (entsel "\n选择曲线:")) 
  p1 (getpoint "\n起点:") 
  p2 (getpoint "\n终点:") 
  l (list p1 p2) 
  l (vl-sort l '(lambda (x y) (< (vlax-curve-getDistAtPoint a x) (vlax-curve-getDistAtPoint a y)) ) ) 
  p1 (car l) 
  p2 (cadr l) 
  d1 (vlax-curve-getDistAtPoint a p1) 
  d2 (vlax-curve-getDistAtPoint a p2) 
  i -1 
  l nil 
) 
(while (< (setq pr (+ (* (setq i (1+ i)) d) d1)) d2) 
  (setq l (cons (vlax-curve-getPointAtDist a pr) l)) 
) 
(setq l (reverse l)) 
(setvar "osmode" 0) 
(princ "\n[1上,2中,3下]") 
(setq aa (grread)) 
(cond 
  ((= (cadr aa) 49) (setq f 1) ) 
  ((= (cadr aa) 50) (setq f 2) ) 
  ((= (cadr aa) 51) (setq f 3) ) 
) 
(mapcar '(lambda(x) 
(setq an (HH:PtFirstAngle a x) q (mat:rotation x an) e (mkarc x w f)) 
(vla-transformby (vlax-ename->vla-object e) (vlax-tmatrix q)) 
) l) 
(mapcar 'setvar '("cmdecho" "osmode") odlst) 
)

如果选择的是类型1，就还要选择是在哪曲线的哪一侧？可以用鼠标指定吗？实际的情况是，程序中用“上，中，下” 来选择的。

=================================================

另外圆弧的方向，实际的情况是输入正负值来完成的，我想直接在对话框上选择，对话框中的方向一项就是用来改变弧形的方向的。（如果能动态指定，那就更好！）

==================================================================

愿程序是不是改变捕捉设置呢？感觉用过之后，捕捉设置都变了，另外，当选择的曲线是圆或椭圆这种封闭曲线时，
我想整个曲线都布置，那起点与终点在一个点上，就没办法做到了。有什么好的方法么？（是不是加个整线布置的选项？如果选中整线布置，就不用选择起点和终点？）

以上感谢大师的帮助！！！

Free-Lancer · 发表于 2014-9-10 21:16:34

本帖最后由 Free-Lancer 于 2014-9-11 00:30 编辑

lucas3 发表于 2014-9-10 18:24
Free-Lancer大师，完整的修改版程序呢？感觉整的挺复杂的！到时还要加载两个库？

只要一个 lib.vlx 即可，这个包含了 app.fas
先写个三点弧

(defun Arc:Make3 (p1 p2 p3 / r d an p pc sa se midp)
(defun midp (p1 p2)
(mapcar '(lambda (x y)
(* 0.5 (+ x y))
)
p1
p2
)
)
(setq d (car (trans (mapcar '- p2 p1) 0 (mapcar '- p3 p1)))
an (angle p1 p3)
_pi2 (/ pi 2)
p11 (midp p1 p2)
p22 (midp p2 p3)
)
(if (setq pc (inters p11
(polar p11 (+ (angle p1 p2) _pi2) 1.)
p22
(polar p22 (+ (angle p2 p3) _pi2) 1.)
nil
)
)
(progn
(setq r (distance p1 pc)
sa (angle pc p1)
se (angle pc p3)
)
(if (minusp d)
(if (and (< sa se) (< (angle pc p2) sa))
(vlax-invoke (fy:acspace) 'AddArc pc r se (+ pi pi sa))
(vlax-invoke (fy:acspace) 'AddArc pc r sa se)
)
(if (< se (angle pc p2) sa) ;_顺时针
(vlax-invoke (fy:acspace) 'AddArc pc r se sa)
(vlax-invoke (fy:acspace) 'AddArc pc r se (+ pi pi sa))
)
)
)
)
)

(defun Arc:Make3 (p1 p2 p3 / r d an p pc sa se midp) 
  (defun midp (p1 p2) 
    (mapcar '(lambda (x y) 
               (* 0.5 (+ x y)) 
             ) 
            p1 
            p2 
    ) 
  ) 
  (setq        d    (car (trans (mapcar '- p2 p1) 0 (mapcar '- p3 p1))) 
        an   (angle p1 p3) 
        _pi2 (/ pi 2) 
        p11  (midp p1 p2) 
        p22  (midp p2 p3) 
  ) 
  (if (setq pc (inters p11 
                       (polar p11 (+ (angle p1 p2) _pi2) 1.) 
                       p22 
                       (polar p22 (+ (angle p2 p3) _pi2) 1.) 
                       nil 
               ) 
      ) 
    (progn 
      (setq r  (distance p1 pc) 
            sa (angle pc p1) 
            se (angle pc p3) 
      ) 
      (if (minusp d) 
        (if (and (< sa se) (< (angle pc p2) sa)) 
          (vlax-invoke (fy:acspace) 'AddArc pc r se (+ pi pi sa)) 
          (vlax-invoke (fy:acspace) 'AddArc pc r sa se) 
        ) 
        (if (< se (angle pc p2) sa) ;_顺时针 
          (vlax-invoke (fy:acspace) 'AddArc pc r se sa) 
          (vlax-invoke (fy:acspace) 'AddArc pc r se (+ pi pi sa)) 
        ) 
      ) 
    ) 
  ) 
)

记录下这个对话框

(setq str '("temp:dialog {"
"label = "焊肉符号" ;"
": column {"
" : row {"
" : column {"
" : image_button { height = 5; key = "sld";}"
" : boxed_column {"
" label = "参数" ;"
" : edit_box { key = "wid"; label = "宽度" ;}"
" : edit_box { key = "dis"; label = "间距" ;}"
" }"
" : toggle {key = "tol"; label = "整线";}"
" }"
" : column {"
" : boxed_column {"
" label="方向";"
" : radio_button { key= "front"; label = "正";}"
" : radio_button { key="back"; label ="反";}"
" }"
" : boxed_column {"
" label = "位置" ;"
" : radio_button { key = "left"; label = "左" ;}"
" : radio_button { key = "mid"; label = "中" ;}"
" : radio_button { key = "right"; label = "右" ;}"
" }}"
" }"
" ok_cancel;"
" errtile;"
" }"
"}"
)
)

(setq    str '("temp:dialog {" 
          "label = "焊肉符号" ;" 
          ": column {" 
          "  : row {" 
          "    : column {" 
          "      : image_button { height = 5; key = "sld";}" 
          "      : boxed_column {" 
          "        label = "参数" ;" 
          "        : edit_box { key = "wid"; label = "宽度" ;}" 
          "        : edit_box { key = "dis"; label = "间距" ;}" 
          "        }" 
          "      : toggle {key = "tol"; label = "整线";}" 
          "    }" 
          "  : column {" 
          "    : boxed_column {" 
          "      label="方向";" 
          "      : radio_button { key= "front"; label = "正";}" 
          "      : radio_button { key="back"; label ="反";}" 
          "      }" 
          "    : boxed_column {" 
          "      label = "位置" ;" 
          "      : radio_button { key = "left"; label = "左" ;}" 
          "      : radio_button { key = "mid"; label = "中" ;}" 
          "      : radio_button { key = "right"; label = "右" ;}" 
          "      }}" 
          "    }" 
          "  ok_cancel;" 
          "  errtile;" 
          "  }" 
          "}" 
         ) 
  )

Free-Lancer · 发表于 2014-9-9 09:12:33

lucas3 发表于 2014-9-11 13:36
回长老，源程序可以的呀，源程序只是不能选择整线布置

End , lib.vlx 已更新

(mapcar '(lambda (x y)
(if (not (eval x))
(set x y)
)
)
'($globle_wid $globle_dis $globle_mode $globle_totle)
'(2.0 1.0 "bmid" "0")
)
(defun c:tt (/ slbname slst params str fn id e sp ep lst n nl pts ptl
dist ml)
;;返回点对应 ARC 三点参数
(defun GetArcPoints (e p v / w2 w4 an an1 tp p1 p2)
(setq an (angle '(0. 0. 0.) v)
an1 (+ an (/ pi 2))
w4 (/ $globle_wid 4.)
w2 (/ $globle_wid 2)
)
(cond
((= $globle_mode "fup")
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= $globle_mode "fmid")
(setq tp (polar p (+ pi an) w4)
p1 (polar tp an1 w2)
p2 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= $globle_mode "fdn")
(setq p2 (polar p (+ an1 pi) $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= $globle_mode "bup")
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) (+ an pi) w4)
)
(list p p1 p2)
)
((= $globle_mode "bmid")
(setq tp (polar p (+ pi an) w4)
p1 (polar tp an1 w2)
p2 (polar tp (+ an1 pi) w2)
)
(list p1 p p2)
)
((= $globle_mode "bdn")
(setq p2 (polar p (+ pi an1) $globle_wid)
p1 (polar (fy:midp p p2) (+ an pi) w4)
)
(list p p1 p2)
)
(t)
)
)
(setq slbname (findfile "sldlib.slb")
ml '(("fup" "左上正向")
("fmid" "居中正向")
("fdn" "右下正向")
("bup" "左上反向")
("bmid" "居中反向")
("bdn" "右下反向")
)
slst '("fup" "fmid" "fdn" "bup" "bmid" "bdn")
params '("wid" "dis")
str '("temp:dialog {"
"label = \"焊肉符号\" ;"
": column {"
" : row {"
" : image_button { height = 6; key = \"fup\";}"
" : image_button { height = 6; key = \"fmid\";}"
" : image_button { height = 6; key = \"fdn\";}"
" }"
" : row {"
" : image_button { height = 6; key = \"bup\";}"
" : image_button { height = 6; key = \"bmid\";}"
" : image_button { height = 6; key = \"bdn\";}"
" }"
" : boxed_row {"
" label = \"参数\";"
" : edit_box { key = \"wid\"; label = \"宽度\" ;}"
" : edit_box { key = \"dis\"; label = \"间距\" ;}"
" : toggle {key = \"tol\"; label = \"整线\";}"
" }"
" ok_cancel;"
" errtile;"
" }"
"}"
)
)
(setq fn (dcl:make str) ;_写出临时 dcl
id (dcl:load fn "temp") ;_加载 DCL 文件
)
;;set_tile
(dcl:settile
'("wid" "dis" "tol")
(mapcar 'vl-princ-to-string
(list $globle_wid $globle_dis $globle_totle)
)
) ;_设置 string 格式按钮默认值
(set_tile $globle_mode "1")
(Dcl:SetError (cadr (assoc $globle_mode ml)))
(mapcar '(lambda (key fn) (Dcl:SlideImage key fn 0))
slst
(list (strcat slbname "(hanroufup)")
(strcat slbname "(hanroufmid)")
(strcat slbname "(hanroufdn)")
(strcat slbname "(hanroubup)")
(strcat slbname "(hanroubmid)")
(strcat slbname "(hanroubdn)")
)
) ;_设置 image_button
(DCL:ChkNumIn params) ;_ 检查数字格式的 edit_box
;;action_tile
(mapcar
'(lambda (x)
(action_tile
x
"(setq $globle_mode $key)(Dcl:SetError (cadr (assoc $key ml)))"
)
)
slst
)
(DCL:EditboxNumAction params '($globle_wid $globle_dis))
(DCL:ToggleAction "tol" '$globle_totle) ;_记录 toggle 按钮状态，全局变量
(DCL:Accept) ;_定义 accept and cancel
;;Main program
(if (and (= (dcl:start id fn) 1) ;_ok
(setq e (car (entsel
"\n拾取曲线: "
;;'((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))
)
)
)
)
(progn
(if (= $globle_totle "1")
(setq lst (list e
(vlax-curve-getstartparam e)
(vlax-curve-getendparam e)
)
)
(if (and (setq sp (getpoint "\nStart Point: "))
(setq ep (getpoint sp "\nEnd Point: "))
)
(setq lst
(cons e
(vl-sort (list (vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e sp)
)
(vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e ep)
)
)
'<
)
)
)
)
)
)
)
;;绘制主程序
(if lst
(progn
(setq dist (fix (- (vlax-curve-getdistatparam e (last lst))
(vlax-curve-getdistatparam e (cadr lst))
)
)
n (fix (/ dist $globle_dis))
nl (XD::Geom:NumDiv (last lst) (cadr lst) n)
pts (mapcar '(lambda (x)
(list (vlax-curve-getpointatparam e x)
(vlax-curve-getfirstderiv e x)
)
)
nl
)
ptl (mapcar '(lambda (x)
(apply 'GetArcPoints (cons e x))
)
pts
)
)
(mapcar '(lambda (x) (apply 'Arc:3pMake x))
ptl
)
)
)
(princ)
)

(mapcar        '(lambda (x y) 
           (if (not (eval x)) 
             (set x y) 
           ) 
         ) 
        '($globle_wid $globle_dis $globle_mode $globle_totle) 
        '(2.0 1.0 "bmid" "0") 
) 
(defun c:tt (/ slbname slst params str fn id e sp ep lst n nl pts ptl 
             dist ml) 
  ;;返回点对应 ARC 三点参数 
  (defun GetArcPoints (e p v / w2 w4 an an1 tp p1 p2) 
    (setq an  (angle '(0. 0. 0.) v) 
          an1 (+ an (/ pi 2)) 
          w4  (/ $globle_wid 4.) 
          w2  (/ $globle_wid 2) 
    ) 
    (cond 
      ((= $globle_mode "fup") 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) an w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= $globle_mode "fmid") 
       (setq tp        (polar p (+ pi an) w4) 
             p1        (polar tp an1 w2) 
             p2        (polar tp (+ pi an1) w2) 
       ) 
       (list p1 p p2) 
      ) 
      ((= $globle_mode "fdn") 
       (setq p2        (polar p (+ an1 pi) $globle_wid) 
             p1        (polar (fy:midp p p2) an w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= $globle_mode "bup") 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) (+ an pi) w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= $globle_mode "bmid") 
       (setq tp        (polar p (+ pi an) w4) 
             p1        (polar tp an1 w2) 
             p2        (polar tp (+ an1 pi) w2) 
       ) 
       (list p1 p p2) 
      ) 
      ((= $globle_mode "bdn") 
       (setq p2        (polar p (+ pi an1) $globle_wid) 
             p1        (polar (fy:midp p p2) (+ an pi) w4) 
       ) 
       (list p p1 p2) 
      ) 
      (t) 
    ) 
  ) 
  (setq        slbname        (findfile "sldlib.slb") 
        ml        '(("fup" "左上正向") 
                  ("fmid" "居中正向") 
                  ("fdn" "右下正向") 
                  ("bup" "左上反向") 
                  ("bmid" "居中反向") 
                  ("bdn" "右下反向") 
                 ) 
        slst        '("fup" "fmid" "fdn" "bup" "bmid" "bdn") 
        params        '("wid" "dis") 
        str        '("temp:dialog {" 
                  "label = \"焊肉符号\" ;" 
                  ": column {" 
                  "  : row {" 
                  "    : image_button { height = 6; key = \"fup\";}" 
                  "    : image_button { height = 6; key = \"fmid\";}" 
                  "    : image_button { height = 6; key = \"fdn\";}" 
                  "    }" 
                  "  : row {" 
                  "    : image_button { height = 6; key = \"bup\";}" 
                  "    : image_button { height = 6; key = \"bmid\";}" 
                  "    : image_button { height = 6; key = \"bdn\";}" 
                  "    }" 
                  "  : boxed_row {" 
                  "    label = \"参数\";" 
                  "    : edit_box { key = \"wid\"; label = \"宽度\" ;}" 
                  "    : edit_box { key = \"dis\"; label = \"间距\" ;}" 
                  "    : toggle {key = \"tol\"; label = \"整线\";}" 
                  "    }" 
                  "  ok_cancel;" 
                  "  errtile;" 
                  "  }" 
                  "}" 
                 ) 
  ) 
  (setq        fn (dcl:make str) ;_写出临时 dcl 
        id (dcl:load fn "temp") ;_加载 DCL 文件 
  ) 
  ;;set_tile   
  (dcl:settile 
    '("wid" "dis" "tol") 
    (mapcar 'vl-princ-to-string 
            (list $globle_wid $globle_dis $globle_totle) 
    ) 
  ) ;_设置 string 格式按钮默认值 
  (set_tile $globle_mode "1") 
  (Dcl:SetError (cadr (assoc $globle_mode ml))) 
  (mapcar '(lambda (key fn) (Dcl:SlideImage key fn 0)) 
          slst 
          (list        (strcat slbname "(hanroufup)") 
                (strcat slbname "(hanroufmid)") 
                (strcat slbname "(hanroufdn)") 
                (strcat slbname "(hanroubup)") 
                (strcat slbname "(hanroubmid)") 
                (strcat slbname "(hanroubdn)") 
          ) 
  ) ;_设置 image_button 
  (DCL:ChkNumIn params) ;_  检查数字格式的 edit_box 
  ;;action_tile 
  (mapcar 
    '(lambda (x) 
       (action_tile 
         x 
         "(setq $globle_mode $key)(Dcl:SetError  (cadr (assoc $key ml)))" 
       ) 
     ) 
    slst 
  ) 
  (DCL:EditboxNumAction params '($globle_wid $globle_dis)) 
  (DCL:ToggleAction "tol" '$globle_totle) ;_记录 toggle 按钮状态，全局变量 
  (DCL:Accept) ;_定义 accept and cancel 
  ;;Main program 
  (if (and (= (dcl:start id fn) 1) ;_ok 
           (setq e (car        (entsel 
                          "\n拾取曲线: " 
                          ;;'((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) 
                        ) 
                   ) 
           ) 
      ) 
    (progn 
      (if (= $globle_totle "1") 
        (setq lst (list        e 
                        (vlax-curve-getstartparam e) 
                        (vlax-curve-getendparam e) 
                  ) 
        ) 
        (if (and (setq sp (getpoint "\nStart Point: ")) 
                 (setq ep (getpoint sp "\nEnd Point: ")) 
            ) 
          (setq        lst 
                 (cons e 
                       (vl-sort        (list (vlax-curve-getparamatpoint 
                                        e 
                                        (vlax-curve-getclosestpointto e sp) 
                                      ) 
                                      (vlax-curve-getparamatpoint 
                                        e 
                                        (vlax-curve-getclosestpointto e ep) 
                                      ) 
                                ) 
                                '< 
                       ) 
                 ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  ;;绘制主程序 
  (if lst 
    (progn 
      (setq dist (fix (- (vlax-curve-getdistatparam e (last lst)) 
                         (vlax-curve-getdistatparam e (cadr lst)) 
                      ) 
                 ) 
            n         (fix (/ dist $globle_dis)) 
            nl         (XD::Geom:NumDiv (last lst) (cadr lst) n) 
            pts         (mapcar '(lambda (x) 
                            (list (vlax-curve-getpointatparam e x) 
                                  (vlax-curve-getfirstderiv e x) 
                            ) 
                          ) 
                         nl 
                 ) 
            ptl         (mapcar '(lambda (x) 
                            (apply 'GetArcPoints (cons e x)) 
                          ) 
                         pts 
                 ) 
      ) 
      (mapcar '(lambda (x) (apply 'Arc:3pMake x)) 
              ptl 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2014-9-9 14:35:52

这个可以有

Free-Lancer · 发表于 2014-9-10 07:56:51

由起点到终点，左右用距离的正负控制，类型分左、中、右

lucas3 · 发表于 2014-9-10 08:07:58

Free-Lancer 发表于 2014-9-10 07:56
由起点到终点，左右用距离的正负控制，类型分左、中、右

大师能帮帮忙吗？加个对话框

Free-Lancer · 发表于 2014-9-10 08:19:44

lucas3 发表于 2014-9-10 08:07
大师能帮帮忙吗？加个对话框

不需要 Slide

lucas3 · 发表于 2014-9-10 09:40:10

Free-Lancer 发表于 2014-9-10 08:19
不需要 Slide

大师，不能动态选择吗？用左，中，右也不是很好区分吧，有时可能是上，中，下，了，另外一个层次考虑，弧线布置在曲线的两侧属于角焊缝，而弧线布置在曲线的中间属于另外一种焊接方式
所以用这种选择方式会比较合理（类型1属于角焊缝）

登录/注册后可看大图

另外弧的方向不能选择吗？

登录/注册后可看大图

下面是SLD文件

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:sld.rar
下载次数:1 文件大小:11.26 KB
下载权限: 不限以上 [免费赚D豆]

st788796 · 发表于 2014-9-10 10:23:05

左中右应以前进方向区分

Free-Lancer · 发表于 2014-9-10 10:43:42

本帖最后由 Free-Lancer 于 2014-9-10 10:46 编辑

lucas3 发表于 2014-9-10 09:40
大师，不能动态选择吗？用左，中，右也不是很好区分吧，有时可能是上，中，下，了，另外一个层次考虑 ...

这样规则, 由起点面向终点区分左中右

lucas3 · 发表于 2014-9-10 10:52:35

Free-Lancer 发表于 2014-9-10 10:43
这样规则, 由起点面向终点区分左中右

大师，输入正负值多麻烦，能否直接做的选择在DCL上呢？
另外，当选择的曲线是圆或椭圆这种封闭曲线时，
我想整个曲线都布置，那起点与终点在一个点上，就没办法做到了。有什么好的方法么？（是不是加个整线布置的选项？如果选中整线布置，就不用选择起点和终点？）

Free-Lancer · 发表于 2014-9-10 11:10:34

lucas3 发表于 2014-9-10 10:52
大师，输入正负值多麻烦，能否直接做的选择在DCL上呢？
另外，当选择的曲线是圆或椭圆这种封闭曲线时，
...

不管怎样都是和起点终点方向有关，对话框部分

(mapcar '(lambda (x y)
(if (not (eval x))
(set x y)
)
)
'($globle_wid $globle_dis $globle_mode $globle_totle)
'(2.0 1.0 "mid" "0")
)
(defun c:tt (/ str fn id)
(setq str '("temp:dialog {"
" label = \"焊肉符号\" ;"
" :column {"
" :boxed_column {"
" label = \"参数\" ;"
" :edit_box {"
" key = \"wid\" ;"
" label = \"宽度\" ;"
" }"
" :edit_box {"
" key = \"dis\" ;"
" label = \"间距\" ;"
" }"
" }"
" :boxed_row {"
" label = \"方向\" ;"
" :radio_button {"
" key = \"left\" ;"
" label = \"左\" ;"
" }"
" :radio_button {"
" key = \"mid\" ;"
" label = \"中\" ;"
" }"
" :radio_button {"
" key = \"right\" ;"
" label = \"右\" ;"
" }"
" }"
" }"
" :row{"
" :toggle{"
" key = \"tol\";"
" label = \"整线\";"
" }"
" ok_only;}"
" errtile;"
"}"
)
)
(setq fn (dcl:make str)
id (dcl:load fn "temp")
)
(dcl:settile
'("wid" "dis" "tol")
(mapcar 'vl-princ-to-string
(list $globle_wid $globle_dis $globle_totle)
)
)
(dcl:radioinit '("left" "mid" "right") $globle_mode)
(dcl:radioaction '("left" "mid" "right") '$globle_mode)
(dcl:doeditbox '("left" "mid") '($globle_wid $globle_dis))
(dcl:dotoggle '("tol") '($globle_totle))
(action_tile
"accept"
(dcl:doeditbox '("wid" "dis") '($globle_wid $globle_dis))
)
(dcl:start id fn)
)
;;===================================================
(defun dcl:dotoggle (keylst syml)
(mapcar '(lambda (x y)
(action_tile
x
(strcat "(setq " (vl-symbol-name y) " $value)")
)
)
keylst
syml
)
)
(defun dcl:doeditbox (keylst syml)
(apply 'strcat
(mapcar '(lambda (x y)
(strcat "(setq "
(vl-symbol-name y)
"(distof (get_tile \""
x
"\")))"
)
)
keylst
syml
)
)
)
(defun Dcl:RadioAction (keylst sym / actionx)
(foreach x keylst
(action_tile
x
(apply
'strcat
(append (list (strcat "(setq " (vl-symbol-name sym) " $key" ")"))
(mapcar '(lambda (x)
(strcat "(set_tile " "\"" x "\"" " \"0\")")
)
keylst
)
(list "(set_tile $key \"1\")")
)
)
)
)
)

(mapcar        '(lambda (x y) 
           (if (not (eval x)) 
             (set x y) 
           ) 
         ) 
        '($globle_wid $globle_dis $globle_mode $globle_totle) 
        '(2.0 1.0 "mid" "0") 
) 
(defun c:tt (/ str fn id) 
  (setq        str '("temp:dialog {" 
              "    label = \"焊肉符号\" ;" 
              "    :column {" 
              "        :boxed_column {" 
              "            label = \"参数\" ;" 
              "            :edit_box {" 
              "                key = \"wid\" ;" 
              "                label = \"宽度\" ;" 
              "            }" 
              "            :edit_box {" 
              "                key = \"dis\" ;" 
              "                label = \"间距\" ;" 
              "            }" 
              "        }" 
              "        :boxed_row {" 
              "            label = \"方向\" ;" 
              "            :radio_button {" 
              "              key      =              \"left\" ;" 
              "                label = \"左\" ;" 
              "            }" 
              "            :radio_button {" 
              "              key      =     \"mid\" ;" 
              "                label = \"中\" ;" 
              "            }" 
              "            :radio_button {" 
              "                key = \"right\" ;" 
              "                label = \"右\" ;" 
              "            }" 
              "        }" 
              "    }" 
              "    :row{" 
              "     :toggle{" 
              "        key = \"tol\";" 
              "        label = \"整线\";" 
              "      }" 
              "      ok_only;}" 
              "    errtile;" 
              "}" 
             ) 
  ) 
  (setq        fn (dcl:make str) 
        id (dcl:load fn "temp") 
  ) 
  (dcl:settile 
    '("wid" "dis" "tol") 
    (mapcar 'vl-princ-to-string 
            (list $globle_wid $globle_dis $globle_totle) 
    ) 
  ) 
  (dcl:radioinit '("left" "mid" "right") $globle_mode) 
  (dcl:radioaction '("left" "mid" "right") '$globle_mode) 
  (dcl:doeditbox '("left" "mid") '($globle_wid $globle_dis)) 
  (dcl:dotoggle '("tol") '($globle_totle)) 
  (action_tile 
    "accept" 
    (dcl:doeditbox '("wid" "dis") '($globle_wid $globle_dis)) 
  ) 
  (dcl:start id fn) 
) 
;;=================================================== 
(defun dcl:dotoggle (keylst syml) 
  (mapcar '(lambda (x y) 
             (action_tile 
               x 
               (strcat "(setq " (vl-symbol-name y) " $value)") 
             ) 
           ) 
          keylst 
          syml 
  ) 
) 
(defun dcl:doeditbox (keylst syml) 
  (apply 'strcat 
         (mapcar '(lambda (x y) 
                    (strcat "(setq " 
                            (vl-symbol-name y) 
                            "(distof (get_tile \"" 
                            x 
                            "\")))" 
                    ) 
                  ) 
                 keylst 
                 syml 
         ) 
  ) 
) 
(defun Dcl:RadioAction (keylst sym / actionx) 
  (foreach x keylst 
    (action_tile 
      x 
      (apply 
        'strcat 
        (append        (list (strcat "(setq " (vl-symbol-name sym) " $key" ")")) 
                (mapcar        '(lambda (x) 
                           (strcat "(set_tile " "\"" x "\"" " \"0\")") 
                         ) 
                        keylst 
                ) 
                (list "(set_tile $key \"1\")") 
        ) 
      ) 
    ) 
  ) 
)

lucas3 · 发表于 2014-9-10 11:21:39

Free-Lancer 发表于 2014-9-10 11:10
不管怎样都是和起点终点方向有关，对话框部分

谢谢Free-Lancer大师，那程序部分呢？

Free-Lancer · 发表于 2014-9-10 16:51:03

本帖最后由 Free-Lancer 于 2014-9-10 16:53 编辑

lucas3 发表于 2014-9-10 11:21
谢谢Free-Lancer大师，那程序部分呢？

基本搞定 edit_box toggle radio_button 这几个控件了，以后再用就方便了

(mapcar '(lambda (x y)
(if (not (eval x))
(set x y)
)
)
'($globle_wid $globle_dis $globle_mode $globle_totle)
'(2.0 1.0 "mid" "0")
)
(defun c:tt (/ str fn id tf dg)
(setq str '("temp:dialog {"
" label = \"焊肉符号\" ;"
" :column {"
" :boxed_column {"
" label = \"参数\" ;"
" :edit_box {"
" key = \"wid\" ;"
" label = \"宽度\" ;"
" }"
" :edit_box {"
" key = \"dis\" ;"
" label = \"间距\" ;"
" }"
" }"
" :boxed_row {"
" label = \"方向\" ;"
" :radio_button {"
" key = \"left\" ;"
" label = \"左\" ;"
" }"
" :radio_button {"
" key = \"mid\" ;"
" label = \"中\" ;"
" }"
" :radio_button {"
" key = \"right\" ;"
" label = \"右\" ;"
" }"
" }"
" }"
" :row{"
" :toggle{"
" key = \"tol\";"
" label = \"整线\";"
" }"
" ok_cancel;}"
" errtile;"
"}"
)
)
(setq fn (dcl:make str) ;_写出临时 dcl
id (dcl:load fn "temp") ;_加载 DCL 文件
)
;;set_tile
;;设置 string 格式按钮默认值
(dcl:settile
'("wid" "dis" "tol")
(mapcar 'vl-princ-to-string
(list $globle_wid $globle_dis $globle_totle)
)
)
;;初始化 radio_button 按钮组
(DCL:RadioInit '("left" "mid" "right") '$globle_mode)
;;检查数字格式的 edit_box
(DCL:ChkNumIn '("wid" "dis"))
;;action_tile
(DCL:RadioAction '("left" "mid" "right") '$globle_mode)
;;数字格式 edit_box 转化为全局变量
(DCL:EditboxNumAction
'("wid" "dis")
'($globle_wid $globle_dis)
)
;;记录 toggle 按钮状态，全局变量
(DCL:ToggleAction "tol" '$globle_totle)
;;ok
(DCL:Accept) ;_定义 accept and cancel
;;Main program
(if (= (dcl:start id fn) 1)
(princ "\nOk!")
)
(princ)
)

(mapcar        '(lambda (x y) 
           (if (not (eval x)) 
             (set x y) 
           ) 
         ) 
        '($globle_wid $globle_dis $globle_mode $globle_totle) 
        '(2.0 1.0 "mid" "0") 
) 
(defun c:tt (/ str fn id tf dg) 
  (setq        str '("temp:dialog {" 
              "    label = \"焊肉符号\" ;" 
              "    :column {" 
              "        :boxed_column {" 
              "            label = \"参数\" ;" 
              "            :edit_box {" 
              "                key = \"wid\" ;" 
              "                label = \"宽度\" ;" 
              "            }" 
              "            :edit_box {" 
              "                key = \"dis\" ;" 
              "                label = \"间距\" ;" 
              "            }" 
              "        }" 
              "        :boxed_row {" 
              "            label = \"方向\" ;" 
              "            :radio_button {" 
              "              key      =              \"left\" ;" 
              "                label = \"左\" ;" 
              "            }" 
              "            :radio_button {" 
              "              key      =     \"mid\" ;" 
              "                label = \"中\" ;" 
              "            }" 
              "            :radio_button {" 
              "                key = \"right\" ;" 
              "                label = \"右\" ;" 
              "            }" 
              "        }" 
              "    }" 
              "    :row{" 
              "      :toggle{" 
              "         key = \"tol\";" 
              "         label = \"整线\";" 
              "      }" 
              "    ok_cancel;}" 
              "    errtile;" 
              "}" 
             ) 
  ) 
  (setq        fn (dcl:make str) ;_写出临时 dcl 
        id (dcl:load fn "temp") ;_加载 DCL 文件 
  ) 
  ;;set_tile 
  ;;设置 string 格式按钮默认值 
  (dcl:settile 
    '("wid" "dis" "tol") 
    (mapcar 'vl-princ-to-string 
            (list $globle_wid $globle_dis $globle_totle) 
    ) 
  ) 
  ;;初始化 radio_button 按钮组 
  (DCL:RadioInit '("left" "mid" "right") '$globle_mode) 
  ;;检查数字格式的 edit_box 
  (DCL:ChkNumIn '("wid" "dis")) 
  ;;action_tile 
  (DCL:RadioAction '("left" "mid" "right") '$globle_mode) 
  ;;数字格式 edit_box 转化为全局变量 
  (DCL:EditboxNumAction 
    '("wid" "dis") 
    '($globle_wid $globle_dis) 
  ) 
  ;;记录 toggle 按钮状态，全局变量 
  (DCL:ToggleAction "tol" '$globle_totle) 
  ;;ok 
  (DCL:Accept) ;_定义 accept and cancel 
  ;;Main program 
  (if (= (dcl:start id fn) 1) 
    (princ "\nOk!") 
  ) 
  (princ) 
)

DCL 控制部分，lib.vlx 已更新

;;=============================================================;
;; Aciton_tile ;
;;=============================================================;
(defun DCL:ToggleAction (keylst syml)
(if (eq (type syml) 'LIST)
(mapcar '(lambda (x y)
(action_tile
x
(strcat "(setq " (vl-symbol-name y) " $value)")
)
)
keylst
syml
)
(action_tile
keylst
(strcat "(setq " (vl-symbol-name syml) " $value)")
)
)
)
;;数字格式Edit_box 控件Action事件
(defun DCL:EditboxNumAction (keylst syml)
(mapcar '(lambda (x y)
(action_tile x
(strcat "(setq "
(vl-symbol-name y)
"(distof (get_tile \""
x
"\")))"
)
)
)
keylst
syml
)
)
;;String 格式 edit_box Action
(defun DCL:EditboxAction (keylst syml)
(apply 'strcat
(mapcar '(lambda (x y)
(strcat "(setq "
(vl-symbol-name y)
"(get_tile \""
x
"\"))"
)
)
keylst
syml
)
)
)
;; Radio 组 Action
;; keylst ---- radio key list
;; def ---- key
(defun Dcl:RadioAction (keylst sym / actions)
(foreach x keylst
(action_tile
x
(apply
'strcat
(append
(list (strcat "(setq " (vl-symbol-name sym) " $key" ")"))
(mapcar '(lambda (x)
(strcat "(set_tile " "\"" x "\"" " \"0\")")
)
keylst
)
(list "(set_tile $key \"1\")")
)
)
)
)
)
;;多组Radio Action
(defun Dcl:mRadioAction (lst)
(mapcar '(lambda (x) (apply 'Dcl:RadioAction x)) lst)
)
(defun Dcl:Accept ()
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
t
)

;;=============================================================; 
;;             Aciton_tile                                     ; 
;;=============================================================; 
(defun DCL:ToggleAction        (keylst syml) 
  (if (eq (type syml) 'LIST) 
    (mapcar '(lambda (x y) 
               (action_tile 
                 x 
                 (strcat "(setq " (vl-symbol-name y) " $value)") 
               ) 
             ) 
            keylst 
            syml 
    ) 
    (action_tile 
      keylst 
      (strcat "(setq " (vl-symbol-name syml) " $value)") 
    ) 
  ) 
) 
;;数字格式Edit_box 控件Action事件 
(defun DCL:EditboxNumAction (keylst syml) 
  (mapcar '(lambda (x y) 
             (action_tile x 
               (strcat "(setq " 
                       (vl-symbol-name y) 
                       "(distof (get_tile \"" 
                       x 
                       "\")))" 
               ) 
             ) 
           ) 
          keylst 
          syml 
  ) 
) 
;;String 格式 edit_box Action 
(defun DCL:EditboxAction (keylst syml) 
  (apply 'strcat 
         (mapcar '(lambda (x y) 
                    (strcat "(setq " 
                            (vl-symbol-name y) 
                            "(get_tile \"" 
                            x 
                            "\"))" 
                    ) 
                  ) 
                 keylst 
                 syml 
         ) 
  ) 
) 
;; Radio 组 Action 
;; keylst ---- radio key list 
;; def    ---- key 
(defun Dcl:RadioAction (keylst sym / actions) 
  (foreach x keylst 
    (action_tile 
      x 
      (apply 
        'strcat 
        (append 
          (list (strcat "(setq " (vl-symbol-name sym) " $key" ")")) 
          (mapcar '(lambda (x) 
                     (strcat "(set_tile " "\"" x "\"" " \"0\")") 
                   ) 
                  keylst 
          ) 
          (list "(set_tile $key \"1\")") 
        ) 
      ) 
    ) 
  ) 
) 
;;多组Radio Action 
(defun Dcl:mRadioAction        (lst) 
  (mapcar '(lambda (x) (apply 'Dcl:RadioAction x)) lst) 
) 
(defun Dcl:Accept () 
  (action_tile "accept" "(done_dialog 1)") 
  (action_tile "cancel" "(done_dialog 0)") 
  t 
)

lucas3 · 发表于 2014-9-10 18:24:10

本帖最后由 lucas3 于 2014-9-10 18:27 编辑

Free-Lancer 发表于 2014-9-10 16:51
基本搞定 edit_box toggle radio_button 这几个控件了，以后再用就方便了

DCL 控制部分，lib.vlx ...

Free-Lancer大师，完整的修改版程序呢？感觉整的挺复杂的！到时还要加载两个库？

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

[已解决] 求修改一个程序（添加dialog ）

最佳答案

相关帖子

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评

评分

点评