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

st788796 · 发表于 2014-9-11 06:55:03

Free-Lancer 发表于 2014-9-10 21:16
只要一个 lib.vlx 即可，这个包含了 app.fas
先写个三点弧

6个Radio_button+1个image_button，不如换成6个image_button更直观，也可以少点一次

Free-Lancer · 发表于 2014-9-11 08:17:58

st788796 发表于 2014-9-11 06:55
6个Radio_button+1个image_button，不如换成6个image_button更直观，也可以少点一次

建议不错，主体框架这样

(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 (/ GetArcPoints cGetPoints slbname
slst params str fn id e
sp ep lst
)
;;返回点对应 ARC 三点参数
(defun GetArcPoints (e p v / p v vc)
(setq vc (xdrx_vector_rotate v _pi2))
(cond
((= $globle_mode "fup"))
((= $globle_mode "fmid"))
((= $globle_mode "fdn"))
((= $globle_mode "bup"))
((= $globle_mode "bmid"))
((= $globle_mode "bdn"))
(t)
)
)
;;返回每个间隔点及切线方向向量
(defun cGetPoints (e spam epam / d n)
(setq d (abs (xdrx_curve_getdistatparam e spam epam))
n (fix (/ d $globle_dis))
)
(mapcar
'(lambda (x)
(list (xdrx_curve_getpointatparam e x)
(xdrx_vector_normalize (xdrx_curve_getfirstderiv e x))
)
)
(XD::Geom:NumDiv
(xdrx_curve_getparamatpoint e ep)
(xdrx_curve_getparamatpoint e sp)
n
)
)
)
(setq slbname (findfile "sldlib.slb")
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 格式按钮默认值
(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)"))
slst
)
(DCL:EditboxNumAction params '($globle_wid $globle_dis))
(DCL:ToggleAction "tol" '$globle_totle) ;_记录 toggle 按钮状态，全局变量
(DCL:Accept) ;_定义 accept and cancel
;;Main program
(if (= (dcl:start id fn) 1) ;_ok
(progn
(setq e (car (xdrx_entsel
"\n拾取曲线: "
'((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))
)
)
)
(if (= $globle_totle "1")
(setq lst (list e
(xdrx_curve_getstartparam e)
(xdrx_curve_getendparam e)
)
)
(if (and (setq sp (getpoint "\nStart Point: "))
(setq ep (getpoint "\nEnd Point: "))
)
(setq lst (list e
(xdrx_curve_getparamatpoint e sp)
(xdrx_curve_getparamatpoint e ep)
)
)
)
)
)
)
;;绘制主程序
(if lst
(princ)
)
(princ)
)
;;==============================================================
(defun Arc:3pMake (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))
(xdrx_circle_make pc r se (+ pi pi sa))
;;(vlax-invoke (fy:acspace) 'AddArc pc r sa se)
(xdrx_circle_make pc r sa se)
)
(if (< se (angle pc p2) sa) ;_顺时针
;;(vlax-invoke (fy:acspace) 'AddArc pc r se sa)
(xdrx_circle_make pc r se sa)
;;(vlax-invoke (fy:acspace) 'AddArc pc r se (+ pi pi sa))
(xdrx_circle_make pc r se (+ pi pi sa))
)
)
)
)
)

(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 (/              GetArcPoints        cGetPoints          slbname 
             slst     params   str        fn         id          e 
             sp              ep       lst 
            ) 
  ;;返回点对应 ARC 三点参数 
  (defun GetArcPoints (e p v / p v vc) 
    (setq vc (xdrx_vector_rotate v _pi2)) 
    (cond 
      ((= $globle_mode "fup")) 
      ((= $globle_mode "fmid")) 
      ((= $globle_mode "fdn")) 
      ((= $globle_mode "bup")) 
      ((= $globle_mode "bmid")) 
      ((= $globle_mode "bdn")) 
      (t) 
    ) 
  ) 
  ;;返回每个间隔点及切线方向向量 
  (defun cGetPoints (e spam epam / d n) 
    (setq d (abs (xdrx_curve_getdistatparam e spam epam)) 
          n (fix (/ d $globle_dis)) 
    ) 
    (mapcar 
      '(lambda (x) 
         (list (xdrx_curve_getpointatparam e x) 
               (xdrx_vector_normalize (xdrx_curve_getfirstderiv e x)) 
         ) 
       ) 
      (XD::Geom:NumDiv 
        (xdrx_curve_getparamatpoint e ep) 
        (xdrx_curve_getparamatpoint e sp) 
        n 
      ) 
    ) 
  ) 
  (setq        slbname        (findfile "sldlib.slb") 
        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 格式按钮默认值 
  (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)")) 
          slst 
  ) 
  (DCL:EditboxNumAction params '($globle_wid $globle_dis)) 
  (DCL:ToggleAction "tol" '$globle_totle) ;_记录 toggle 按钮状态，全局变量 
  (DCL:Accept) ;_定义 accept and cancel 
  ;;Main program 
  (if (= (dcl:start id fn) 1) ;_ok 
    (progn 
      (setq e (car (xdrx_entsel 
                     "\n拾取曲线: " 
                     '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")) 
                   ) 
              ) 
      ) 
      (if (= $globle_totle "1") 
        (setq lst (list        e 
                        (xdrx_curve_getstartparam e) 
                        (xdrx_curve_getendparam e) 
                  ) 
        ) 
        (if (and (setq sp (getpoint "\nStart Point: ")) 
                 (setq ep (getpoint "\nEnd Point: ")) 
            ) 
          (setq        lst (list e 
                          (xdrx_curve_getparamatpoint e sp) 
                          (xdrx_curve_getparamatpoint e ep) 
                    ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  ;;绘制主程序 
  (if lst 
    (princ) 
  ) 
  (princ) 
) 
;;============================================================== 
(defun Arc:3pMake (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)) 
          (xdrx_circle_make pc r se (+ pi pi sa)) 
          ;;(vlax-invoke (fy:acspace) 'AddArc pc r sa se) 
          (xdrx_circle_make pc r sa se) 
        ) 
        (if (< se (angle pc p2) sa) ;_顺时针 
          ;;(vlax-invoke (fy:acspace) 'AddArc pc r se sa) 
          (xdrx_circle_make pc r se sa) 
          ;;(vlax-invoke (fy:acspace) 'AddArc pc r se (+ pi pi sa)) 
          (xdrx_circle_make pc r se (+ pi pi sa)) 
        ) 
      ) 
    ) 
  ) 
)

lucas3 · 发表于 2014-9-11 08:46:36

Free-Lancer 发表于 2014-9-11 08:17
建议不错，主体框架这样

看起来很cool ,期待最终版本

Free-Lancer · 发表于 2014-9-11 09:37:00

lucas3 发表于 2014-9-11 08:46
看起来很cool ,期待最终版本

加上 Slide 就是这样，主程序用 xdapi 函数写起来就简单了

lucas3 · 发表于 2014-9-11 09:54:04

Free-Lancer 发表于 2014-9-11 09:37
加上 Slide 就是这样，主程序用 xdapi 函数写起来就简单了

Free-Lancer大师，确实漂亮，谢谢！
不要用API函数写啊，{:soso_e109:}，用您的app函数也行啊
不然要加载的就太多了，本来的意愿是想在q3_2006 前辈的程序上稍做修改，{:soso_e109:}

Free-Lancer · 发表于 2014-9-11 11:19:12

lucas3 发表于 2014-9-11 09:54
Free-Lancer大师，确实漂亮，谢谢！
不要用API函数写啊，，用您的app函数也行啊
不然要 ...

那就先凑合吧

(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 dv l an p1 p2 aa a an d
d1 d2 e f i odlst p1 p2 pr q
w x y
)
(setq slbname (findfile "sldlib.slb")
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")
(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)"))
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
;;(setq dv (* (/ 5. 16.) $globle_wid))
(if (= $globle_totle "1")
(setq l (list e
(vlax-curve-getstartparam e)
(vlax-curve-getendparam e)
)
)
(if (and (setq sp (getpoint "\nStart Point: "))
(setq ep (getpoint "\nEnd Point: "))
)
(setq l (cons e
(vl-sort (vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e sp)
)
(vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e ep)
)
'<
)
)
)
)
)
)
)
;;绘制主程序
(if l
(progn
(setq odlst (mapcar 'getvar '("cmdecho" "osmode" "peditaccept")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 544))
(if (member $globle_mode '("bup" "bmid" "bdn"))
(setq w (- $globle_wid))
(setq w $globle_wid)
)
(setq d $globle_dis
d1 (vlax-curve-getDistAtparam (car l) (cadr l))
d2 (vlax-curve-getDistAtparam (car l) (last l))
a (car l)
i -1
l nil
)
(while (< (setq pr (+ (* (setq i (1+ i)) d) d1)) d2)
(setq l (cons (vlax-curve-getPointAtparam a pr) l))
)
(setq l (reverse l))
(setvar "osmode" 0)
(cond
((member $globle_mode '("fup" "bup")) (setq f 1))
((member $globle_mode '("fmid" "bmid")) (setq f 2))
(t (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)
)
)
(princ)
)
;;==============================================================
(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))
)
)

(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  dv   l         an   p1   p2        aa   a          an   d 
             d1          d2   e    f         i    odlst        p1   p2          pr   q 
             w          x    y 
            ) 
 
  (setq        slbname        (findfile "sldlib.slb") 
        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") 
  (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)")) 
          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 
      ;;(setq dv (* (/ 5. 16.) $globle_wid)) 
      (if (= $globle_totle "1") 
        (setq l        (list e 
                      (vlax-curve-getstartparam e) 
                      (vlax-curve-getendparam e) 
                ) 
        ) 
        (if (and (setq sp (getpoint "\nStart Point: ")) 
                 (setq ep (getpoint "\nEnd Point: ")) 
            ) 
          (setq        l (cons        e 
                        (vl-sort (vlax-curve-getparamatpoint 
                                   e 
                                   (vlax-curve-getclosestpointto e sp) 
                                 ) 
                                 (vlax-curve-getparamatpoint 
                                   e 
                                   (vlax-curve-getclosestpointto e ep) 
                                 ) 
                                 '< 
                        ) 
                  ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  ;;绘制主程序 
  (if l 
    (progn 
      (setq odlst (mapcar 'getvar '("cmdecho" "osmode" "peditaccept"))) 
      (mapcar 'setvar '("cmdecho" "osmode") '(0 544)) 
      (if (member $globle_mode '("bup" "bmid" "bdn")) 
        (setq w (- $globle_wid)) 
        (setq w $globle_wid) 
      ) 
      (setq d  $globle_dis 
            d1 (vlax-curve-getDistAtparam (car l) (cadr l)) 
            d2 (vlax-curve-getDistAtparam (car l) (last l)) 
            a  (car l) 
            i  -1 
            l  nil 
      ) 
      (while (< (setq pr (+ (* (setq i (1+ i)) d) d1)) d2) 
        (setq l (cons (vlax-curve-getPointAtparam a pr) l)) 
      ) 
      (setq l (reverse l)) 
      (setvar "osmode" 0) 
      (cond 
        ((member $globle_mode '("fup" "bup")) (setq f 1)) 
        ((member $globle_mode '("fmid" "bmid")) (setq f 2)) 
        (t (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) 
    ) 
  ) 
  (princ) 
) 
;;============================================================== 
(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)) 
  ) 
)

lucas3 · 发表于 2014-9-11 11:51:48

Free-Lancer 发表于 2014-9-11 11:19
那就先凑合吧

谢谢！可是还有好多问题，起点终点绘制提示，错误: 参数太多，整线布置时，多段线，矩形等都不成功！还是等最终版吧

st788796 · 发表于 2014-9-11 12:52:31

lucas3 发表于 2014-9-11 11:51
谢谢！可是还有好多问题，起点终点绘制提示，错误: 参数太多，整线布置时，多段线，矩形等都不成功！还 ...

源程序可以吗？

lucas3 · 发表于 2014-9-11 13:36:41

st788796 发表于 2014-9-11 12:52
源程序可以吗？

回长老，源程序可以的呀，源程序只是不能选择整线布置

lucas3 · 发表于 2014-9-11 19:19:22

本帖最后由 lucas3 于 2014-9-11 20:26 编辑

Free-Lancer 发表于 2014-9-9 09:12
End , lib.vlx 已更新

谢谢Free-Lancer大师，晓东的活雷锋！非常感谢！很有用的样例程序！有一点建议！就是幻灯片选中与被选中不好查看，能否选中后背景变为白色？之前有见过这样的示例

还有一个问题，绕死我了！我觉得应该用从起始点到--->终点的方向来决定弧的方向上图：以第三种方式为例

起始点在左，终点在右，向右旋转后，就相当起点在上，终点在下

或者继续向右旋转，直到，起点在下，终点在上

测试：两条线，分别以起始点在上和起始点在下测试，但结果都是一样，跟左侧的对比不同

另外，拿一条直线跟多段线测试，起点都在上方
测试结果又不一样！

对过上方的测试发现，果真绕晕了！有时真不知选择哪一种方式来绘制了
有一个想法，不需要6个幻灯片，只需要2个，就像我发的主题里的那个一样，一个是弧在线侧边，一个是在中间，
如果绘制时选择的是在侧边，那么选择起点和终点后（或整线），可以预览，可以通过一个按键来改变弧的方向，另一个按键来改变在曲线的一侧还是另一侧，满意后，空格或右键结束！如果选择的是弧在曲线的中间，就简单点，那么绘制后，只需一个按键来改变弧的方向，满意后结束。

st788796 · 发表于 2014-9-11 20:08:04

在指定两点的时候可以不考虑线的方向，只和拾取方向有关
整线布置时可以提示一个方向

Free-Lancer · 发表于 2014-9-11 20:41:00

lucas3 发表于 2014-9-11 19:19
谢谢Free-Lancer大师，晓东的活雷锋！非常感谢！很有用的样例程序！有一点建议！就是幻灯片选中与被选中 ...

DCL 部分都是源码，自己加上几句就可以将当前的背景变白
第二个问题和曲线方向有关，用 reverse 转向一下就知道了

(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 (/ ImageAction GetArcPoints 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)
)
)
(defun ImageAction ()
(apply 'Dcl:SlideImage
(append (assoc $globle_mode slst) '(0))
)
(setq $globle_mode $key)
(apply 'dcl:slideimage (append (assoc $key slst) '(7)))
(Dcl:SetError (cadr (assoc $key ml)))
)
(setq slbname (findfile "sldlib.slb")
ml '(("fup" "左上正向")
("fmid" "居中正向")
("fdn" "右下正向")
("bup" "左上反向")
("bmid" "居中反向")
("bdn" "右下反向")
)
slst (list
(list "fup" (strcat slbname "(hanroufup)"))
(list "fmid" (strcat slbname "(hanroufmid)"))
(list "fdn" (strcat slbname "(hanroufdn)"))
(list "bup" (strcat slbname "(hanroubup)"))
(list "bmid" (strcat slbname "(hanroubmid)"))
(list "bdn" (strcat slbname "(hanroubdn)"))
)
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 (x)
(if (= (car x) $globle_mode)
(apply 'Dcl:SlideImage (append x '(7)))
(apply 'Dcl:SlideImage (append x '(0)))
)
)
slst
) ;_设置 image_button
(DCL:ChkNumIn params) ;_ 检查数字格式的 edit_box
;;action_tile
(mapcar '(lambda (x) (action_tile x "(ImageAction)"))
(mapcar 'car 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拾取曲线: ")))
(wcmatch (cdr (assoc 0 (entget e)))
"*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
(fy:begin)
(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
)
(fy:end)
)
)
(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 (/             ImageAction     GetArcPoints    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) 
    ) 
  ) 
  (defun ImageAction () 
    (apply 'Dcl:SlideImage 
           (append (assoc $globle_mode slst) '(0)) 
    ) 
    (setq $globle_mode $key) 
    (apply 'dcl:slideimage (append (assoc $key slst) '(7))) 
    (Dcl:SetError (cadr (assoc $key ml))) 
  ) 
  (setq        slbname        (findfile "sldlib.slb") 
        ml        '(("fup" "左上正向") 
                  ("fmid" "居中正向") 
                  ("fdn" "右下正向") 
                  ("bup" "左上反向") 
                  ("bmid" "居中反向") 
                  ("bdn" "右下反向") 
                 ) 
        slst        (list 
                  (list "fup" (strcat slbname "(hanroufup)")) 
                  (list "fmid" (strcat slbname "(hanroufmid)")) 
                  (list "fdn" (strcat slbname "(hanroufdn)")) 
                  (list "bup" (strcat slbname "(hanroubup)")) 
                  (list "bmid" (strcat slbname "(hanroubmid)")) 
                  (list "bdn" (strcat slbname "(hanroubdn)")) 
                ) 
        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 (x) 
             (if (= (car x) $globle_mode) 
               (apply 'Dcl:SlideImage (append x '(7))) 
               (apply 'Dcl:SlideImage (append x '(0))) 
             ) 
           ) 
          slst 
  ) ;_设置 image_button 
  (DCL:ChkNumIn params) ;_  检查数字格式的 edit_box 
  ;;action_tile 
  (mapcar '(lambda (x) (action_tile x "(ImageAction)")) 
          (mapcar 'car 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拾取曲线: "))) 
           (wcmatch (cdr (assoc 0 (entget e))) 
                    "*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 
      (fy:begin) 
      (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 
      ) 
      (fy:end) 
    ) 
  ) 
  (princ) 
)

lucas3 · 发表于 2014-9-11 20:55:47

Free-Lancer 发表于 2014-9-11 20:41
DCL 部分都是源码，自己加上几句就可以将当前的背景变白
第二个问题和曲线方向有关，用 reverse 转向 ...

Free-Lancer大师，第二个问题，方向的问题还是没有解决呀

st788796 · 发表于 2014-9-11 21:28:35

在不改变曲线方向情况下，两点间可以由拾取先后确定方向，但整线时仍旧需要两点确定方向

lucas3 · 发表于 2014-9-11 23:21:33

st788796 发表于 2014-9-11 21:28
在不改变曲线方向情况下，两点间可以由拾取先后确定方向，但整线时仍旧需要两点确定方向

我觉得对于封闭图形，比如圆，矩形等，选择了起始点与终止点后，还应该选择是哪一段，否侧会在相反的一侧绘制

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

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

点评

点评

点评

点评

点评

点评

点评

点评

点评

评分

点评

点评

点评

点评