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

st788796 · 发表于 2014-9-11 23:46:18

lucas3 发表于 2014-9-11 23:21
我觉得对于封闭图形，比如圆，矩形等，选择了起始点与终止点后，还应该选择是哪一段，否侧会在相反的一侧 ...

把选线或选边提前以确定方向，完成后再显示对话框就不会搞错了

Free-Lancer · 发表于 2014-9-12 08:25:02

lucas3 发表于 2014-9-11 23:21
我觉得对于封闭图形，比如圆，矩形等，选择了起始点与终止点后，还应该选择是哪一段，否侧会在相反的一侧 ...

闭合线需要改造一下 XD::Geom:NumDiv 函数

只和取点方向有关好办，判断一下两点的参数大小，如果反向时将 Firstderiv 反转 180 度，并且点表 reverse 即可

lucas3 · 发表于 2014-9-12 08:39:09

Free-Lancer 发表于 2014-9-12 08:25
闭合线需要改造一下 XD::Geom:NumDiv 函数

只和取点方向有关好办，判断一下两点的参数大小，如果反 ...

大师，我觉得多选几次是没关系的，只要一次能画准，否则画过之后，不对，删除再画，再不对，再删除再画，这样反复几次就更悲剧呀。
我见有的程序关于方向是这样操作的：绘制后出现一个提示，方向正确吗？输入Y就结束，输入N 就反转到另一侧。

st788796 · 发表于 2014-9-12 09:07:59

lucas3 发表于 2014-9-12 08:39
大师，我觉得多选几次是没关系的，只要一次能画准，否则画过之后，不对，删除再画，再不对，再删除再画 ...

你这个相当于四个方向, 如果要再提示还要前面的6个选择方式干什么

lucas3 · 发表于 2014-9-12 09:30:04

st788796 发表于 2014-9-12 09:07
你这个相当于四个方向, 如果要再提示还要前面的6个选择方式干什么

回长老，我没有要求6个选择方式啊，我的目的只有一个，1.如果选择的是圆弧在曲线中间，那么就需要选择圆弧的方向

2.如果选择的是圆弧在曲线侧边，那么就需要选择圆弧的方向，还需要选择是在曲线的哪一侧。

lucas3 · 发表于 2014-9-12 17:41:53

Free-Lancer 发表于 2014-9-12 08:25
闭合线需要改造一下 XD::Geom:NumDiv 函数

只和取点方向有关好办，判断一下两点的参数大小，如果反 ...

期待大师出招完善啊，拜托{:soso_e183:}

Free-Lancer · 发表于 2014-9-13 08:37:50

lucas3 发表于 2014-9-12 17:41
期待大师出招完善啊，拜托

先测试下，下载新的 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 (/ IsClosed GetArcPoints slbname slst
params str fn id e sp ep
lst n nl pts ptl dist cspam
cepam spam epam tpam e0
)
(defun IsClosed (e)
(or (vlax-curve-isclosed e)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-3
)
)
)
;;返回点对应 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)
)
)
(if (and (setq e (car (entsel "\n拾取曲线: ")))
(wcmatch (cdr (assoc 0 (entget e)))
"*LINE,ARC,CIRCLE,ELLIPSE"
)
)
(progn
(setq slbname (findfile "sldlib.slb")
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 (last (assoc $globle_mode slst)))
(DCL:ChkNumIn params) ;_ 检查数字格式的 edit_box
(DCL:ImageButton 'slst '$globle_mode)
(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
(if (= $globle_totle "1")
(progn
(setq cspam (vlax-curve-getstartparam e)
cepam (vlax-curve-getendparam e)
)
(DrawDirct e)
(if (and (isclosed e)
(setq tpam (half e))
)
(if (> tpam (* 0.5 cepam)) ;_逆向
(setq nl
(XD::Geom:NumDiv cepam 0.0 (float $globle_dis))
)
(setq nl
(XD::Geom:NumDiv 0.0 cepam (float $globle_dis))
) ;_正向
)
)
)
(if (and (setq sp (getpoint "\nStart Point: "))
(setq ep (getpoint sp "\nEnd Point: "))
)
(progn
(setq spam (vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e sp)
)
epam (vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e ep)
)
)
(if (and (isclosed e)
(progn
(grdraw sp ep 1 -1)
t
)
(setq e0 (entsel "\n选择标注方向边: "))
(setq tpam
(vlax-curve-getparamatpoint
(car e0)
(apply 'vlax-curve-getclosestpointto e0)
)
)
)
(if (or (< spam tpam epam) ;_正向
(> spam tpam epam)
) ;_逆向
(setq nl (XD::Geom:NumDiv
(vlax-curve-getdistatparam e spam)
(vlax-curve-getdistatparam e epam)
(float $globle_dis)
)
)
(setq nl
(XD::Geom:NumDiv
(vlax-curve-getdistatparam e spam)
(vlax-curve-getdistatparam e epam)
(list (vlax-curve-getdistatparam
e
(vlax-curve-getendparam e)
)
$globle_dis
)
)
)
)
(setq
nl
(XD::Geom:NumDiv epam spam (float $globle_dis))
)
)
)
)
)
(fy:begin)
;;绘制主程序
(if nl
(progn (setq tf (> spam epam)
pts (mapcar '(lambda (x / v)
(setq v (vlax-curve-getfirstderiv
e
(vlax-curve-getparamatdist e x)
)
)
(list (vlax-curve-getpointatdist e x)
(if tf
(mapcar '- v)
v
)
)
)
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 (/             IsClosed             GetArcPoints    slbname slst 
             params  str     fn             id             e             sp             ep 
             lst     n             nl             pts     ptl     dist    cspam 
             cepam   spam    epam    tpam    e0 
            ) 
  (defun IsClosed (e) 
    (or        (vlax-curve-isclosed e) 
        (equal (vlax-curve-getstartpoint e) 
               (vlax-curve-getendpoint e) 
               1e-3 
        ) 
    ) 
  ) 
  ;;返回点对应 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) 
    ) 
  ) 
  (if (and (setq e (car (entsel "\n拾取曲线: "))) 
           (wcmatch (cdr (assoc 0 (entget e))) 
                    "*LINE,ARC,CIRCLE,ELLIPSE" 
           ) 
      ) 
    (progn 
      (setq slbname (findfile "sldlib.slb") 
            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 (last (assoc $globle_mode slst))) 
      (DCL:ChkNumIn params) ;_  检查数字格式的 edit_box 
      (DCL:ImageButton 'slst '$globle_mode) 
      (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 
          (if (= $globle_totle "1") 
            (progn 
              (setq cspam (vlax-curve-getstartparam e) 
                    cepam (vlax-curve-getendparam e) 
              ) 
              (DrawDirct e) 
              (if (and (isclosed e) 
                       (setq tpam (half e)) 
                  ) 
                (if (> tpam (* 0.5 cepam)) ;_逆向 
                  (setq        nl 
                         (XD::Geom:NumDiv cepam 0.0 (float $globle_dis)) 
                  ) 
                  (setq        nl 
                         (XD::Geom:NumDiv 0.0 cepam (float $globle_dis)) 
                  ) ;_正向 
                ) 
              ) 
            ) 
            (if        (and (setq sp (getpoint "\nStart Point: ")) 
                     (setq ep (getpoint sp "\nEnd Point: ")) 
                ) 
              (progn 
                (setq spam (vlax-curve-getparamatpoint 
                             e 
                             (vlax-curve-getclosestpointto e sp) 
                           ) 
                      epam (vlax-curve-getparamatpoint 
                             e 
                             (vlax-curve-getclosestpointto e ep) 
                           ) 
                ) 
                (if (and (isclosed e) 
                         (progn 
                           (grdraw sp ep 1 -1) 
                           t 
                         ) 
                         (setq e0 (entsel "\n选择标注方向边: ")) 
                         (setq tpam 
                                (vlax-curve-getparamatpoint 
                                  (car e0) 
                                  (apply 'vlax-curve-getclosestpointto e0) 
                                ) 
                         ) 
                    ) 
                  (if (or (< spam tpam epam) ;_正向 
                          (> spam tpam epam) 
                      ) ;_逆向 
                    (setq nl (XD::Geom:NumDiv 
                               (vlax-curve-getdistatparam e spam) 
                               (vlax-curve-getdistatparam e epam) 
                               (float $globle_dis) 
                             ) 
                    ) 
                    (setq nl 
                           (XD::Geom:NumDiv 
                             (vlax-curve-getdistatparam e spam) 
                             (vlax-curve-getdistatparam e epam) 
                             (list (vlax-curve-getdistatparam 
                                     e 
                                     (vlax-curve-getendparam e) 
                                   ) 
                                   $globle_dis 
                             ) 
                           ) 
                    ) 
                  ) 
                  (setq 
                    nl 
                     (XD::Geom:NumDiv epam spam (float $globle_dis)) 
                  ) 
                ) 
              ) 
            ) 
          ) 
          (fy:begin) 
          ;;绘制主程序 
          (if nl 
            (progn (setq tf  (> spam epam) 
                         pts (mapcar '(lambda (x / v) 
                                        (setq v        (vlax-curve-getfirstderiv 
                                                  e 
                                                  (vlax-curve-getparamatdist e x) 
                                                ) 
                                        ) 
                                        (list (vlax-curve-getpointatdist e x) 
                                              (if tf 
                                                (mapcar '- v) 
                                                v 
                                              ) 
                                        ) 
                                      ) 
                                     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-13 10:01:02

Free-Lancer 发表于 2014-9-13 08:37
先测试下，下载新的 lib.vlx

谢谢大师继续跟进，{:soso_e179:}
测试的结果如下：
1.直线能点对点布置，但整线布置出错，
2. 整线布置均出错
3. 不封闭的多段线（圆弧，椭圆弧，多段线）均出错，但样条曲线可以
4.对于封闭曲线的处理，选择哪一段布置，这个做的比较好！
5.圆弧的方向和布置在曲线的哪一侧，真的很难弄清楚

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

lucas3 发表于 2014-9-13 10:01
谢谢大师继续跟进，
测试的结果如下：
1.直线能点对点布置，但整线布置出错，

整线加了方向提示和是否反向选择

(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 (/ IsClosed GetArcPoints slbname slst
params str fn id e sp ep
lst n nl pts ptl dist cspam
cepam spam epam tpam e0 key
)
(defun DrawDirct (e / sp v an p1 p2 p3 d1)
(setq sp (vlax-curve-getstartpoint e)
v (vlax-curve-getfirstderiv e (vlax-curve-getstartparam e))
d (distance '(0. 0. 0.) v)
d1 (if (equal d
(vlax-curve-getdistatparam
e
(vlax-curve-getendparam e)
)
1e-3
)
(setq d1 (/ d 2.))
(setq d1 d)
)
an (angle '(0. 0. 0.) v)
p1 (polar sp an d1)
p2 (polar p1 (+ an (* 1.25 pi)) (/ (distance sp p1) 6.))
p3 (polar p1 (- an (* 1.25 pi)) (/ (distance sp p1) 6.))
)
(grvecs (list 1 sp p1 1 p1 p2 1 p1 p3))
t
)
(defun IsClosed (e)
(or (vlax-curve-isclosed e)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-3
)
)
)
;;返回点对应 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)
)
)
(if (and (setq e (car (entsel "\n拾取曲线: ")))
(wcmatch (cdr (assoc 0 (entget e)))
"*LINE,ARC,CIRCLE,ELLIPSE"
)
(if (= $globle_totle "1")
(DrawDirct e)
t
)
)
(progn
(setq slbname (findfile "sldlib.slb")
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 (last (assoc $globle_mode slst)))
(DCL:ChkNumIn params) ;_ 检查数字格式的 edit_box
(DCL:ImageButton 'slst '$globle_mode)
(DCL:EditboxNumAction params '($globle_wid $globle_dis))
;;(DCL:ToggleAction "tol" '$globle_totle) ;_记录 toggle 按钮状态，全局变量
(action_tile
"tol"
"(setq $globle_totle $value) (DrawDirct e)"
)
(DCL:Accept) ;_定义 accept and cancel
;;Main program
(if (= (dcl:start id fn) 1) ;_ok
(progn
(if (= $globle_totle "1")
(progn
(DrawDirct e)
(setq cspam (vlax-curve-getstartparam e)
cepam (vlax-curve-getendparam e)
)
(initget "Y N")
(setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: "))
(if (or (not key) (= key ""))
(setq nl
(XD::Geom:NumDiv
(vlax-curve-getdistatparam e cepam)
0.0
(float $globle_dis)
)
)
(setq nl
(XD::Geom:NumDiv
0.0
(vlax-curve-getdistatparam e cepam)
(float $globle_dis)
)
) ;_正向
)
)
(if (and (setq sp (getpoint "\nStart Point: "))
(setq ep (getpoint sp "\nEnd Point: "))
)
(progn
(setq spam (vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e sp)
)
epam (vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e ep)
)
)
(if (and (isclosed e)
(progn
(grdraw sp ep 1 -1)
t
)
(setq e0 (entsel "\n选择标注方向边: "))
(setq tpam
(vlax-curve-getparamatpoint
(car e0)
(apply 'vlax-curve-getclosestpointto e0)
)
)
)
(if (or (< spam tpam epam) ;_正向
(> spam tpam epam)
) ;_逆向
(setq nl (XD::Geom:NumDiv
(vlax-curve-getdistatparam e spam)
(vlax-curve-getdistatparam e epam)
(float $globle_dis)
)
)
(setq nl
(XD::Geom:NumDiv
(vlax-curve-getdistatparam e spam)
(vlax-curve-getdistatparam e epam)
(list (vlax-curve-getdistatparam
e
(vlax-curve-getendparam e)
)
$globle_dis
)
)
)
)
(setq
nl
(XD::Geom:NumDiv epam spam (float $globle_dis))
)
)
)
)
)
(fy:begin)
;;绘制主程序
(if nl
(progn (setq tf (> spam epam)
pts (mapcar '(lambda (x / v)
(setq v (vlax-curve-getfirstderiv
e
(vlax-curve-getparamatdist e x)
)
)
(list (vlax-curve-getpointatdist e x)
(if tf
(mapcar '- v)
v
)
)
)
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 (/             IsClosed             GetArcPoints    slbname slst 
             params  str     fn             id             e             sp             ep 
             lst     n             nl             pts     ptl     dist    cspam 
             cepam   spam    epam    tpam    e0             key 
            ) 
  (defun DrawDirct (e / sp v an p1 p2 p3 d1) 
    (setq sp (vlax-curve-getstartpoint e) 
          v  (vlax-curve-getfirstderiv e (vlax-curve-getstartparam e)) 
          d  (distance '(0. 0. 0.) v) 
          d1 (if (equal        d 
                        (vlax-curve-getdistatparam 
                          e 
                          (vlax-curve-getendparam e) 
                        ) 
                        1e-3 
                 ) 
               (setq d1 (/ d 2.)) 
               (setq d1 d) 
             ) 
          an (angle '(0. 0. 0.) v) 
          p1 (polar sp an d1) 
          p2 (polar p1 (+ an (* 1.25 pi)) (/ (distance sp p1) 6.)) 
          p3 (polar p1 (- an (* 1.25 pi)) (/ (distance sp p1) 6.)) 
    ) 
    (grvecs (list 1 sp p1 1 p1 p2 1 p1 p3)) 
    t 
  ) 
  (defun IsClosed (e) 
    (or        (vlax-curve-isclosed e) 
        (equal (vlax-curve-getstartpoint e) 
               (vlax-curve-getendpoint e) 
               1e-3 
        ) 
    ) 
  ) 
  ;;返回点对应 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) 
    ) 
  ) 
  (if (and (setq e (car (entsel "\n拾取曲线: "))) 
           (wcmatch (cdr (assoc 0 (entget e))) 
                    "*LINE,ARC,CIRCLE,ELLIPSE" 
           ) 
           (if (= $globle_totle "1") 
             (DrawDirct e) 
             t 
           ) 
      ) 
    (progn 
      (setq slbname (findfile "sldlib.slb") 
            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 (last (assoc $globle_mode slst))) 
      (DCL:ChkNumIn params) ;_  检查数字格式的 edit_box 
      (DCL:ImageButton 'slst '$globle_mode) 
      (DCL:EditboxNumAction params '($globle_wid $globle_dis)) 
      ;;(DCL:ToggleAction "tol" '$globle_totle) ;_记录 toggle 按钮状态，全局变量 
      (action_tile 
        "tol" 
        "(setq $globle_totle $value) (DrawDirct e)" 
      ) 
      (DCL:Accept) ;_定义 accept and cancel 
      ;;Main program 
      (if (= (dcl:start id fn) 1) ;_ok 
        (progn 
          (if (= $globle_totle "1") 
            (progn 
              (DrawDirct e) 
              (setq cspam (vlax-curve-getstartparam e) 
                    cepam (vlax-curve-getendparam e) 
              ) 
              (initget "Y N") 
              (setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: ")) 
              (if (or (not key) (= key "")) 
                (setq nl 
                       (XD::Geom:NumDiv 
                         (vlax-curve-getdistatparam e cepam) 
                         0.0 
                         (float $globle_dis) 
                       ) 
                ) 
                (setq nl 
                       (XD::Geom:NumDiv 
                         0.0 
                         (vlax-curve-getdistatparam e cepam) 
                         (float $globle_dis) 
                       ) 
                ) ;_正向 
              ) 
            ) 
            (if        (and (setq sp (getpoint "\nStart Point: ")) 
                     (setq ep (getpoint sp "\nEnd Point: ")) 
                ) 
              (progn 
                (setq spam (vlax-curve-getparamatpoint 
                             e 
                             (vlax-curve-getclosestpointto e sp) 
                           ) 
                      epam (vlax-curve-getparamatpoint 
                             e 
                             (vlax-curve-getclosestpointto e ep) 
                           ) 
                ) 
                (if (and (isclosed e) 
                         (progn 
                           (grdraw sp ep 1 -1) 
                           t 
                         ) 
                         (setq e0 (entsel "\n选择标注方向边: ")) 
                         (setq tpam 
                                (vlax-curve-getparamatpoint 
                                  (car e0) 
                                  (apply 'vlax-curve-getclosestpointto e0) 
                                ) 
                         ) 
                    ) 
                  (if (or (< spam tpam epam) ;_正向 
                          (> spam tpam epam) 
                      ) ;_逆向 
                    (setq nl (XD::Geom:NumDiv 
                               (vlax-curve-getdistatparam e spam) 
                               (vlax-curve-getdistatparam e epam) 
                               (float $globle_dis) 
                             ) 
                    ) 
                    (setq nl 
                           (XD::Geom:NumDiv 
                             (vlax-curve-getdistatparam e spam) 
                             (vlax-curve-getdistatparam e epam) 
                             (list (vlax-curve-getdistatparam 
                                     e 
                                     (vlax-curve-getendparam e) 
                                   ) 
                                   $globle_dis 
                             ) 
                           ) 
                    ) 
                  ) 
                  (setq 
                    nl 
                     (XD::Geom:NumDiv epam spam (float $globle_dis)) 
                  ) 
                ) 
              ) 
            ) 
          ) 
          (fy:begin) 
          ;;绘制主程序 
          (if nl 
            (progn (setq tf  (> spam epam) 
                         pts (mapcar '(lambda (x / v) 
                                        (setq v        (vlax-curve-getfirstderiv 
                                                  e 
                                                  (vlax-curve-getparamatdist e x) 
                                                ) 
                                        ) 
                                        (list (vlax-curve-getpointatdist e x) 
                                              (if tf 
                                                (mapcar '- v) 
                                                v 
                                              ) 
                                        ) 
                                      ) 
                                     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-13 11:32:10

Free-Lancer 发表于 2014-9-13 10:56
整线加了方向提示和是否反向选择

大师，测试结果如下：
1.未封闭曲线的点对点用不了
2. 对于从右往左画的直线，选择是否反向，输Y或输N 都是一样的，不反向，而对于从左往右画的直线就可以反向
3.对于整线布置，选择的，圆，矩形，圆弧，椭圆弧，样条曲线，选择是否反向，都不能改变。

st788796 · 发表于 2014-9-13 11:55:49

后面判断不对，spam epam只是对两点时有效，既然是dist前面构造 nl 时先排好，后面用 (> (car nl) (cadr nl))判断是否取反向切向量

lucas3 · 发表于 2014-9-13 12:08:39

另外，从现在的方法来讲，不用6个slide来选择了，:dizzy:

st788796 · 发表于 2014-9-13 12:55:12

lucas3 发表于 2014-9-13 12:08
另外，从现在的方法来讲，不用6个slide来选择了，

6是和前进方向有关，整段的在选择时一般不知道方向，Lisp语句运行和屏幕显示往往不同步，比如grdraw运行中没有延迟的话，是不能及时反映到屏幕的

Free-Lancer · 发表于 2014-9-13 13:50:45

本帖最后由 Free-Lancer 于 2014-9-13 13:52 编辑

st788796 发表于 2014-9-13 12:55
6是和前进方向有关，整段的在选择时一般不知道方向，Lisp语句运行和屏幕显示往往不同步，比如grdraw运 ...

整理整理

(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 (/ GetDistAtPoint DrawDirct Curve:Length
IsClosed GetArcPoints slbname slst params
str fn id e sp ep
lst n nl pts ptl dist
cedis sdis edis tdis e0 key
$dis
)
(defun GetDistAtPoint (e p)
(vlax-curve-getdistatpoint
e
(vlax-curve-getclosestpointto e p)
)
)
(defun Curve:Length (e)
(vlax-curve-getdistatparam e (vlax-curve-getendparam e))
)
(defun DrawDirct (e / sp v an p1 p2 p3 d1 d)
(setq sp (vlax-curve-getstartpoint e)
v (vlax-curve-getfirstderiv e (vlax-curve-getstartparam e))
d (distance '(0. 0. 0.) v)
d1 (if (equal d
(vlax-curve-getdistatparam
e
(vlax-curve-getendparam e)
)
1e-3
)
(setq d1 (/ d 2.))
(setq d1 d)
)
an (angle '(0. 0. 0.) v)
p1 (polar sp an d1)
p2 (polar p1 (+ an (* 1.25 pi)) (/ (distance sp p1) 6.))
p3 (polar p1 (- an (* 1.25 pi)) (/ (distance sp p1) 6.))
)
(grvecs (list 1 sp p1 1 p1 p2 1 p1 p3))
t
)
(defun IsClosed (e)
(or (vlax-curve-isclosed e)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-3
)
)
)
(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)
)
)
(if (and (setq e (car (entsel "\n拾取曲线: ")))
(wcmatch (cdr (assoc 0 (entget e)))
"*LINE,ARC,CIRCLE,ELLIPSE"
)
)
(progn
(setq slbname (findfile "sldlib.slb")
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)
id (dcl:load fn "temp")
)
(dcl:settile
'("wid" "dis" "tol")
(mapcar 'vl-princ-to-string
(list $globle_wid $globle_dis $globle_totle)
)
)
(Dcl:SetError (last (assoc $globle_mode slst)))
(DCL:ChkNumIn params)
(DCL:ImageButton 'slst '$globle_mode)
(DCL:EditboxNumAction params '($globle_wid $globle_dis))
(DCL:ToggleAction "tol" '$globle_totle)
(DCL:Accept)
(if (= (dcl:start id fn) 1)
(progn
(setq $dis (float $globle_dis))
(if (= $globle_totle "1")
(progn
(DrawDirct e)
(setq cedis (Curve:Length e))
(initget "Y N")
(setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: "))
(if (= key "Y")
(setq nl (XD::Geom:NumDiv cedis 0.0 $dis))
(setq nl (XD::Geom:NumDiv 0.0 cedis $dis))
)
)
(if (and (setq sp (getpoint "\nStart Point: "))
(setq ep (getpoint sp "\nEnd Point: "))
)
(progn
(setq sdis (GetDistAtPoint e sp)
edis (GetDistAtPoint e ep)
cedis (Curve:Length e)
)
(if (and (isclosed e)
(progn
(DrawDirct e)
(grdraw sp ep 1 -1)
t
)
(setq e0 (entsel "\n选择标注方向边: "))
(setq tdis (apply 'GetDistAtPoint e0))
)
(if (or (< sdis tdis edis)
(> sdis tdis edis)
)
(setq nl (XD::Geom:NumDiv edis sdis $dis))
(setq nl (XD::Geom:NumDiv edis sdis (list cedis $dis)))
)
(setq nl (XD::Geom:NumDiv edis sdis $dis))
)
)
)
)
(fy:begin)
(if nl
(progn
(setq tf (> (car nl) (cadr nl))
pts (mapcar '(lambda (x / v)
(setq v (vlax-curve-getfirstderiv
e
(vlax-curve-getparamatdist e x)
)
)
(list (vlax-curve-getpointatdist e x)
(if tf
(mapcar '- v)
v
)
)
)
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 (/              GetDistAtPoint        DrawDirct          Curve:Length 
             IsClosed GetArcPoints        slbname         slst          params 
             str      fn       id        e         sp          ep 
             lst      n               nl        pts         ptl          dist 
             cedis    sdis     edis        tdis         e0          key 
             $dis 
            ) 
  (defun GetDistAtPoint        (e p) 
    (vlax-curve-getdistatpoint 
      e 
      (vlax-curve-getclosestpointto e p) 
    ) 
  ) 
  (defun Curve:Length (e) 
    (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) 
  ) 
  (defun DrawDirct (e / sp v an p1 p2 p3 d1 d) 
    (setq sp (vlax-curve-getstartpoint e) 
          v  (vlax-curve-getfirstderiv e (vlax-curve-getstartparam e)) 
          d  (distance '(0. 0. 0.) v) 
          d1 (if (equal        d 
                        (vlax-curve-getdistatparam 
                          e 
                          (vlax-curve-getendparam e) 
                        ) 
                        1e-3 
                 ) 
               (setq d1 (/ d 2.)) 
               (setq d1 d) 
             ) 
          an (angle '(0. 0. 0.) v) 
          p1 (polar sp an d1) 
          p2 (polar p1 (+ an (* 1.25 pi)) (/ (distance sp p1) 6.)) 
          p3 (polar p1 (- an (* 1.25 pi)) (/ (distance sp p1) 6.)) 
    ) 
    (grvecs (list 1 sp p1 1 p1 p2 1 p1 p3)) 
    t 
  ) 
  (defun IsClosed (e) 
    (or        (vlax-curve-isclosed e) 
        (equal (vlax-curve-getstartpoint e) 
               (vlax-curve-getendpoint e) 
               1e-3 
        ) 
    ) 
  ) 
  (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) 
    ) 
  ) 
  (if (and (setq e (car (entsel "\n拾取曲线: "))) 
           (wcmatch (cdr (assoc 0 (entget e))) 
                    "*LINE,ARC,CIRCLE,ELLIPSE" 
           ) 
      ) 
    (progn 
      (setq slbname (findfile "sldlib.slb") 
            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) 
            id (dcl:load fn "temp") 
      ) 
      (dcl:settile 
        '("wid" "dis" "tol") 
        (mapcar        'vl-princ-to-string 
                (list $globle_wid $globle_dis $globle_totle) 
        ) 
      ) 
      (Dcl:SetError (last (assoc $globle_mode slst))) 
      (DCL:ChkNumIn params) 
      (DCL:ImageButton 'slst '$globle_mode) 
      (DCL:EditboxNumAction params '($globle_wid $globle_dis)) 
      (DCL:ToggleAction "tol" '$globle_totle) 
      (DCL:Accept) 
      (if (= (dcl:start id fn) 1) 
        (progn 
          (setq $dis (float $globle_dis)) 
          (if (= $globle_totle "1") 
            (progn 
              (DrawDirct e) 
              (setq cedis (Curve:Length e)) 
              (initget "Y N") 
              (setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: ")) 
              (if (= key "Y") 
                (setq nl (XD::Geom:NumDiv cedis 0.0 $dis)) 
                (setq nl (XD::Geom:NumDiv 0.0 cedis $dis)) 
              ) 
            ) 
            (if        (and (setq sp (getpoint "\nStart Point: ")) 
                     (setq ep (getpoint sp "\nEnd Point: ")) 
                ) 
              (progn 
                (setq sdis  (GetDistAtPoint e sp) 
                      edis  (GetDistAtPoint e ep) 
                      cedis (Curve:Length e) 
                ) 
                (if (and (isclosed e) 
                         (progn 
                           (DrawDirct e) 
                           (grdraw sp ep 1 -1) 
                           t 
                         ) 
                         (setq e0 (entsel "\n选择标注方向边: ")) 
                         (setq tdis (apply 'GetDistAtPoint e0)) 
                    ) 
                  (if (or (< sdis tdis edis) 
                          (> sdis tdis edis) 
                      ) 
                    (setq nl (XD::Geom:NumDiv edis sdis $dis)) 
                    (setq nl (XD::Geom:NumDiv edis sdis (list cedis $dis))) 
                  ) 
                  (setq nl (XD::Geom:NumDiv edis sdis $dis)) 
                ) 
              ) 
            ) 
          ) 
          (fy:begin) 
          (if nl 
            (progn 
              (setq tf        (> (car nl) (cadr nl)) 
                    pts        (mapcar        '(lambda (x / v) 
                                   (setq v (vlax-curve-getfirstderiv 
                                             e 
                                             (vlax-curve-getparamatdist e x) 
                                           ) 
                                   ) 
                                   (list (vlax-curve-getpointatdist e x) 
                                         (if tf 
                                           (mapcar '- v) 
                                           v 
                                         ) 
                                   ) 
                                 ) 
                                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-13 16:10:28

本帖最后由 lucas3 于 2014-9-13 16:11 编辑

Free-Lancer 发表于 2014-9-13 13:50
整理整理

谢谢！辛苦了！{:soso_e160:}
下面两个问题解决了{:soso_e179:}

2. 对于从右往左画的直线，选择是否反向，输Y或输N 都是一样的，不反向，而对于从左往右画的直线就可以反向
3.对于整线布置，选择的，圆，矩形，圆弧，椭圆弧，样条曲线，选择是否反向，都不能改变。

复制代码

强烈请求 Free-Lancer大师考虑一下更换对话框，在曲线的哪一侧还是容易搞反，
比如，一条从右往左绘制的直线，选择最后一种模式“右下反向”，选择整线布置，
选择“是否反向” ，选是，则圆弧布置上曲线上方，选否，则圆弧布置在曲线下方，这是否合理呢？幻灯片所示，无论怎么操作圆弧应在曲线下方才对，反向只是改圆弧方向，是吧。
真的，这个对话框太不友好！太容易搞晕的了，现在可以由起点到终点的方式来确定方向了，（整线布置有专门针对的选项选择）所以建议只用两个幻灯片，一个就是：
圆弧在曲上中间：这样，可以通过起点到终点的方式来确定方向（整线布置有专门针对的选项选择）
圆弧在曲线两侧：跟上条一样确定圆弧的方向，至于是在曲线哪一侧，可以鼠标指定

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

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

点评

点评

点评

点评

点评

点评

点评

点评