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

lucas3 · 发表于 2014-9-14 19:10:08

另外，选择的是非直线，比如圆，圆弧等等，想要曲弧布置在曲线中间，好难呀

Free-Lancer · 发表于 2014-9-14 23:42:06

lucas3 发表于 2014-9-14 18:42
大师，又更新呢？
还是以直线测试，整线布置，选择是否反向，选择“是”，结果就是错误: 参数类型错 ...

闭合反向有个笔误 vec 写成了 v ，后凹的 an 写成了 (+ pi an), 线上布置直接在线上点

(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" "0")
)
(defun c:tt (/ GetArcPoints slbname slst params str
fn id e sp ep lst n
nl pts ptl dist cedis csdis sdis
edis tdis key mod $dis result startpoint
tf isclosed vec d dp len
v x
)
(defun GetArcPoints (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 ((= mod 10)
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 18)
(setq tp (polar p (+ pi an) w4)
p2 (polar tp an1 w2)
p1 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 34)
(setq p2 (polar p (+ pi an1) $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 12)
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) (+ pi an) w4)
)
(list p p1 p2)
)
((= mod 20)
(setq tp (polar p an w4)
p1 (polar tp an1 w2)
p2 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 36)
(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 "fmid" (strcat slbname "(hanroufmid)") "前凸")
(list "bmid" (strcat slbname "(hanroubmid)") "后凹")
)
params '("wid" "dis")
str '("temp:dialog {"
"label = \"焊肉符号\" ;"
": column {"
" : row {"
" : image_button { height = 6; key = \"fmid\";}"
" : image_button { height = 6; key = \"bmid\";}"
" }"
" : boxed_row {"
" label = \"参数\";"
" : edit_box { key = \"wid\"; label = \"宽度\" ;}"
" : edit_box { key = \"dis\"; label = \"间距\" ;}"
" }"
" : row {"
" : 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:ChkNumIn params)
(DCL:ImageButton 'slst '$globle_mode)
(DCL:EditboxNumAction params '($globle_wid $globle_dis))
(DCL:ToggleAction "tol" '$globle_totle)
(DCL:Accept)
(setq result (dcl:start id fn))
(if (= result 1)
(progn
(setq $dis (float $globle_dis)
isclosed (Curve:IsClosed e)
startpoint (vlax-curve-getstartpoint e)
mod (if (= $globle_mode "fmid")
2
4
)
)
(if (= $globle_totle "1")
(progn (setq vec (Curve:GetFirstDeriv e startpoint)
len (Curve:Length e)
)
(Pnt:Mark (vlax-curve-getstartpoint e) 1)
(Pnt:DrawArrow startpoint vec)
(initget "Y N")
(setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: "))
(if (/= key "Y")
(setq sdis 0.0
tf nil
edis len
sp startpoint
)
(progn (redraw)
(setq ep (vlax-curve-getendpoint e))
(Pnt:DrawArrow ep (mapcar '- vec))
(setq sdis len
edis 0.0
tf t
vec (mapcar '- vec)
sp ep
)
)
)
)
(and (setq sp (getpoint "\n起点: "))
(Pnt:Mark sp 1)
(setq ep (getpoint sp "\n终点: "))
(Pnt:DrawCrossHair ep 3)
(setq sdis (Curve:GetDistAt e sp)
edis (Curve:GetDistAt e ep)
tf (> sdis edis)
vec (Curve:GetFirstDeriv e sp)
)
(if tf
(setq vec (mapcar '- vec))
t
)
(Pnt:DrawArrow sp vec)
(progn (and isclosed (progn (grdraw sp ep 1 -1) t)) t)
)
)
(if
(and sp
(setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: "))
(setq tdis (Curve:GetDistAt e dp))
(setq d (car (trans (mapcar '- dp sp) 0 vec)))
(cond ((or (equal d 0.0 1e-3) (Curve:IsOn e dp))
(setq mod (+ mod 16))
)
((> d 0.0) (setq mod (+ mod 8)))
(t (setq mod (+ mod 32)))
)
(if isclosed
(if (or (< sdis tdis edis) (> sdis tdis edis))
(setq nl (XD::Geom:NumDiv edis sdis $dis))
(setq nl (XD::Geom:NumDiv
edis
sdis
(list (curve:length e) $dis)
)
)
)
(if (or (< sdis tdis edis) (> sdis tdis edis))
(setq nl (XD::Geom:NumDiv edis sdis $dis))
)
)
)
(progn (fy:begin)
(setq pts (mapcar '(lambda (x / v)
(setq v (Curve:GetFirstDeriv e x))
(list (vlax-curve-getpointatdist e x)
(if tf
(mapcar '- v)
v
)
)
)
nl
)
ptl (mapcar '(lambda (x) (apply 'GetArcPoints x)) pts)
)
(mapcar '(lambda (x) (apply 'Arc:3pMake x)) ptl)
(redraw)
(fy:end)
)
)
)
)
)
)
(princ)
)
(defun Curve:IsOn (e pt)
(equal pt (vlax-curve-getclosestpointto e pt) 1e-4)
)

(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" "0") 
) 
(defun c:tt (/             GetArcPoints    slbname slst    params  str 
             fn             id             e             sp             ep             lst     n 
             nl             pts     ptl     dist    cedis   csdis   sdis 
             edis    tdis    key     mod     $dis    result  startpoint 
             tf             isclosed             vec     d             dp             len 
             v             x 
            ) 
  (defun GetArcPoints (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 ((= mod 10) 
           (setq p2 (polar p an1 $globle_wid) 
                 p1 (polar (fy:midp p p2) an w4) 
           ) 
           (list p p1 p2) 
          ) 
          ((= mod 18) 
           (setq tp (polar p (+ pi an) w4) 
                 p2 (polar tp an1 w2) 
                 p1 (polar tp (+ pi an1) w2) 
           ) 
           (list p1 p p2) 
          ) 
          ((= mod 34) 
           (setq p2 (polar p (+ pi an1) $globle_wid) 
                 p1 (polar (fy:midp p p2) an w4) 
           ) 
           (list p p1 p2) 
          ) 
          ((= mod 12) 
           (setq p2 (polar p an1 $globle_wid) 
                 p1 (polar (fy:midp p p2) (+ pi an) w4) 
           ) 
           (list p p1 p2) 
          ) 
          ((= mod 20) 
           (setq tp (polar p an w4) 
                 p1 (polar tp an1 w2) 
                 p2 (polar tp (+ pi an1) w2) 
           ) 
           (list p1 p p2) 
          ) 
          ((= mod 36) 
           (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 "fmid" (strcat slbname "(hanroufmid)") "前凸") 
                          (list "bmid" (strcat slbname "(hanroubmid)") "后凹") 
                    ) 
            params  '("wid" "dis") 
            str            '("temp:dialog {" 
                      "label = \"焊肉符号\" ;" 
                      ": column {" 
                      "  : row {" 
                      "    : image_button { height = 6;   key = \"fmid\";}" 
                      "    : image_button { height = 6;   key = \"bmid\";}" 
                      "    }" 
                      "  : boxed_row {" 
                      "    label = \"参数\";" 
                      "    : edit_box { key = \"wid\"; label = \"宽度\" ;}" 
                      "    : edit_box { key = \"dis\"; label = \"间距\" ;}" 
                      "    }" 
                      "  : row {" 
                      "    : 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:ChkNumIn params) 
      (DCL:ImageButton 'slst '$globle_mode) 
      (DCL:EditboxNumAction params '($globle_wid $globle_dis)) 
      (DCL:ToggleAction "tol" '$globle_totle) 
      (DCL:Accept) 
      (setq result (dcl:start id fn)) 
      (if (= result 1) 
        (progn 
          (setq        $dis           (float $globle_dis) 
                isclosed   (Curve:IsClosed e) 
                startpoint (vlax-curve-getstartpoint e) 
                mod           (if (= $globle_mode "fmid") 
                             2 
                             4 
                           ) 
          ) 
          (if (= $globle_totle "1") 
            (progn (setq vec (Curve:GetFirstDeriv e startpoint) 
                         len (Curve:Length e) 
                   ) 
                   (Pnt:Mark (vlax-curve-getstartpoint e) 1) 
                   (Pnt:DrawArrow startpoint vec) 
                   (initget "Y N") 
                   (setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: ")) 
                   (if (/= key "Y") 
                     (setq sdis        0.0 
                           tf        nil 
                           edis        len 
                           sp        startpoint 
                     ) 
                     (progn (redraw) 
                            (setq ep (vlax-curve-getendpoint e)) 
                            (Pnt:DrawArrow ep (mapcar '- vec)) 
                            (setq sdis len 
                                  edis 0.0 
                                  tf   t 
                                  vec  (mapcar '- vec) 
                                  sp   ep 
                            ) 
                     ) 
                   ) 
            ) 
            (and (setq sp (getpoint "\n起点: ")) 
                 (Pnt:Mark sp 1) 
                 (setq ep (getpoint sp "\n终点: ")) 
                 (Pnt:DrawCrossHair ep 3) 
                 (setq sdis (Curve:GetDistAt e sp) 
                       edis (Curve:GetDistAt e ep) 
                       tf   (> sdis edis) 
                       vec  (Curve:GetFirstDeriv e sp) 
                 ) 
                 (if tf 
                   (setq vec (mapcar '- vec)) 
                   t 
                 ) 
                 (Pnt:DrawArrow sp vec) 
                 (progn (and isclosed (progn (grdraw sp ep 1 -1) t)) t) 
            ) 
          ) 
          (if 
            (and sp 
                 (setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: ")) 
                 (setq tdis (Curve:GetDistAt e dp)) 
                 (setq d (car (trans (mapcar '- dp sp) 0 vec))) 
                 (cond ((or (equal d 0.0 1e-3) (Curve:IsOn e dp)) 
                        (setq mod (+ mod 16)) 
                       ) 
                       ((> d 0.0) (setq mod (+ mod 8))) 
                       (t (setq mod (+ mod 32))) 
                 ) 
                 (if isclosed 
                   (if (or (< sdis tdis edis) (> sdis tdis edis)) 
                     (setq nl (XD::Geom:NumDiv edis sdis $dis)) 
                     (setq nl (XD::Geom:NumDiv 
                                edis 
                                sdis 
                                (list (curve:length e) $dis) 
                              ) 
                     ) 
                   ) 
                   (if (or (< sdis tdis edis) (> sdis tdis edis)) 
                     (setq nl (XD::Geom:NumDiv edis sdis $dis)) 
                   ) 
                 ) 
            ) 
             (progn (fy:begin) 
                    (setq pts (mapcar '(lambda (x / v) 
                                         (setq v (Curve:GetFirstDeriv e x)) 
                                         (list (vlax-curve-getpointatdist e x) 
                                               (if tf 
                                                 (mapcar '- v) 
                                                 v 
                                               ) 
                                         ) 
                                       ) 
                                      nl 
                              ) 
                          ptl (mapcar '(lambda (x) (apply 'GetArcPoints x)) pts) 
                    ) 
                    (mapcar '(lambda (x) (apply 'Arc:3pMake x)) ptl) 
                    (redraw) 
                    (fy:end) 
             ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
(defun Curve:IsOn (e pt) 
  (equal pt (vlax-curve-getclosestpointto e pt) 1e-4) 
)

lucas3 · 发表于 2014-9-15 00:50:28

Free-Lancer 发表于 2014-9-14 23:42
闭合反向有个笔误 vec 写成了 v ，后凹的 an 写成了 (+ pi an), 线上布置直接在线上点

谢谢Free-Lancer大师，这次真的很棒，感谢您的不离不弃，终于完成了！体验非常好！
只是还有一点小瑕疵，就是像圆弧，椭圆弧，选择“反向”后，箭头方向就反了，然后拾取在圆弧内部，结果布置在了圆弧的外侧了
这个小问题如果能解决当然最好，不好解决，也不是很大的问题，注意到这种情况就好了。

Free-Lancer · 发表于 2014-9-15 00:55:35

lucas3 发表于 2014-9-15 00:50
谢谢Free-Lancer大师，这次真的很棒，感谢您的不离不弃，终于完成了！体验非常好！
只是还有一点小瑕疵 ...

点的方向不对，已经有提示了，左右是以切线区分，不能看曲线

st788796 · 发表于 2014-9-15 01:04:46

本帖最后由 st788796 于 2014-9-15 01:23 编辑

这些编组是不是删时除更方便
(Pnt:drawArrow ep (mapcar '- vec))
转向后这句仅对line正确，弧线不对，应用ep的反向firstderiv
(Pnt:drawArrow ep (mapcar '- (Curve:getfirstderiv e ep))

Free-Lancer · 发表于 2014-9-15 07:37:37

lucas3 发表于 2014-9-15 00:50
谢谢Free-Lancer大师，这次真的很棒，感谢您的不离不弃，终于完成了！体验非常好！
只是还有一点小瑕疵 ...

如 st788796 所言，调整两句话既可，更新 lib.vlx 将 Curve:IsOn 加入

(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" "0")
)
(defun c:tt (/ GetArcPoints slbname slst params str
fn id e sp ep lst n
nl pts ptl dist cedis csdis sdis
edis tdis key mod $dis result startpoint
tf isclosed vec d dp len
v x
)
(defun GetArcPoints (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 ((= mod 10)
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 18)
(setq tp (polar p (+ pi an) w4)
p2 (polar tp an1 w2)
p1 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 34)
(setq p2 (polar p (+ pi an1) $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 12)
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) (+ pi an) w4)
)
(list p p1 p2)
)
((= mod 20)
(setq tp (polar p an w4)
p1 (polar tp an1 w2)
p2 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 36)
(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 "fmid" (strcat slbname "(hanroufmid)") "前凸")
(list "bmid" (strcat slbname "(hanroubmid)") "后凹")
)
params '("wid" "dis")
str '("temp:dialog {"
"label = \"焊肉符号\" ;"
": column {"
" : row {"
" : image_button { height = 6; key = \"fmid\";}"
" : image_button { height = 6; key = \"bmid\";}"
" }"
" : boxed_row {"
" label = \"参数\";"
" : edit_box { key = \"wid\"; label = \"宽度\" ;}"
" : edit_box { key = \"dis\"; label = \"间距\" ;}"
" }"
" : row {"
" : 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)
(setq result (dcl:start id fn))
(if (= result 1)
(progn
(setq $dis (float $globle_dis)
isclosed (Curve:IsClosed e)
startpoint (vlax-curve-getstartpoint e)
mod (if (= $globle_mode "fmid")
2
4
)
)
(if (= $globle_totle "1")
(progn (setq vec (Curve:GetFirstDeriv e startpoint)
len (Curve:Length e)
)
(Pnt:Mark (vlax-curve-getstartpoint e) 1)
(Pnt:DrawArrow startpoint vec)
(initget "Y N")
(setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: "))
(if (/= key "Y")
(setq sdis 0.0
tf nil
edis len
sp startpoint
)
(progn (redraw)
(setq ep (vlax-curve-getendpoint e))
(Pnt:DrawArrow
ep
(setq vec (mapcar '-
(Curve:GetFirstDeriv
e
(vlax-curve-getendpoint
e
)
)
)
)
)
(setq sdis len
edis 0.0
tf t
;;vec (mapcar '- vec)
sp ep
)
)
)
)
(and (setq sp (getpoint "\n起点: "))
(Pnt:Mark sp 1)
(setq ep (getpoint sp "\n终点: "))
(Pnt:DrawCrossHair ep 3)
(setq sdis (Curve:GetDistAt e sp)
edis (Curve:GetDistAt e ep)
tf (> sdis edis)
vec (Curve:GetFirstDeriv e sp)
)
(if tf
(setq vec (mapcar '- vec))
t
)
(Pnt:DrawArrow sp vec)
(progn (and isclosed (progn (grdraw sp ep 1 -1) t)) t)
)
)
(if
(and sp
(setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: "))
(setq tdis (Curve:GetDistAt e dp))
(setq d (car (trans (mapcar '- dp sp) 0 vec)))
(cond ((or (equal d 0.0 1e-3) (Curve:IsOn e dp))
(setq mod (+ mod 16))
)
((> d 0.0) (setq mod (+ mod 8)))
(t (setq mod (+ mod 32)))
)
(if isclosed
(if (or (< sdis tdis edis) (> sdis tdis edis))
(setq nl (XD::Geom:NumDiv edis sdis $dis))
(setq nl (XD::Geom:NumDiv
edis
sdis
(list (curve:length e) $dis)
)
)
)
(if (or (< sdis tdis edis) (> sdis tdis edis))
(setq nl (XD::Geom:NumDiv edis sdis $dis))
)
)
)
(progn (fy:begin)
(setq pts (mapcar '(lambda (x / v)
(setq v (Curve:GetFirstDeriv e x))
(list (vlax-curve-getpointatdist e x)
(if tf
(mapcar '- v)
v
)
)
)
nl
)
ptl (mapcar '(lambda (x) (apply 'GetArcPoints x)) pts)
)
(mapcar '(lambda (x) (apply 'Arc:3pMake x)) ptl)
(redraw)
(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" "0") 
) 
(defun c:tt (/             GetArcPoints    slbname slst    params  str 
             fn             id             e             sp             ep             lst     n 
             nl             pts     ptl     dist    cedis   csdis   sdis 
             edis    tdis    key     mod     $dis    result  startpoint 
             tf             isclosed             vec     d             dp             len 
             v             x 
            ) 
  (defun GetArcPoints (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 ((= mod 10) 
           (setq p2 (polar p an1 $globle_wid) 
                 p1 (polar (fy:midp p p2) an w4) 
           ) 
           (list p p1 p2) 
          ) 
          ((= mod 18) 
           (setq tp (polar p (+ pi an) w4) 
                 p2 (polar tp an1 w2) 
                 p1 (polar tp (+ pi an1) w2) 
           ) 
           (list p1 p p2) 
          ) 
          ((= mod 34) 
           (setq p2 (polar p (+ pi an1) $globle_wid) 
                 p1 (polar (fy:midp p p2) an w4) 
           ) 
           (list p p1 p2) 
          ) 
          ((= mod 12) 
           (setq p2 (polar p an1 $globle_wid) 
                 p1 (polar (fy:midp p p2) (+ pi an) w4) 
           ) 
           (list p p1 p2) 
          ) 
          ((= mod 20) 
           (setq tp (polar p an w4) 
                 p1 (polar tp an1 w2) 
                 p2 (polar tp (+ pi an1) w2) 
           ) 
           (list p1 p p2) 
          ) 
          ((= mod 36) 
           (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 "fmid" (strcat slbname "(hanroufmid)") "前凸") 
                          (list "bmid" (strcat slbname "(hanroubmid)") "后凹") 
                    ) 
            params  '("wid" "dis") 
            str            '("temp:dialog {" 
                      "label = \"焊肉符号\" ;" 
                      ": column {" 
                      "  : row {" 
                      "    : image_button { height = 6;   key = \"fmid\";}" 
                      "    : image_button { height = 6;   key = \"bmid\";}" 
                      "    }" 
                      "  : boxed_row {" 
                      "    label = \"参数\";" 
                      "    : edit_box { key = \"wid\"; label = \"宽度\" ;}" 
                      "    : edit_box { key = \"dis\"; label = \"间距\" ;}" 
                      "    }" 
                      "  : row {" 
                      "    : 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) 
      (setq result (dcl:start id fn)) 
      (if (= result 1) 
        (progn 
          (setq        $dis           (float $globle_dis) 
                isclosed   (Curve:IsClosed e) 
                startpoint (vlax-curve-getstartpoint e) 
                mod           (if (= $globle_mode "fmid") 
                             2 
                             4 
                           ) 
          ) 
          (if (= $globle_totle "1") 
            (progn (setq vec (Curve:GetFirstDeriv e startpoint) 
                         len (Curve:Length e) 
                   ) 
                   (Pnt:Mark (vlax-curve-getstartpoint e) 1) 
                   (Pnt:DrawArrow startpoint vec) 
                   (initget "Y N") 
                   (setq key (getkword "\n是否反向[Yes(Y)/No(N)]<N>: ")) 
                   (if (/= key "Y") 
                     (setq sdis        0.0 
                           tf        nil 
                           edis        len 
                           sp        startpoint 
                     ) 
                     (progn (redraw) 
                            (setq ep (vlax-curve-getendpoint e)) 
                            (Pnt:DrawArrow 
                              ep 
                              (setq vec        (mapcar        '- 
                                                (Curve:GetFirstDeriv 
                                                  e 
                                                  (vlax-curve-getendpoint 
                                                    e 
                                                  ) 
                                                ) 
                                        ) 
                              ) 
                            ) 
                            (setq sdis len 
                                  edis 0.0 
                                  tf   t 
                                  ;;vec  (mapcar '- vec) 
                                  sp   ep 
                            ) 
                     ) 
                   ) 
            ) 
            (and (setq sp (getpoint "\n起点: ")) 
                 (Pnt:Mark sp 1) 
                 (setq ep (getpoint sp "\n终点: ")) 
                 (Pnt:DrawCrossHair ep 3) 
                 (setq sdis (Curve:GetDistAt e sp) 
                       edis (Curve:GetDistAt e ep) 
                       tf   (> sdis edis) 
                       vec  (Curve:GetFirstDeriv e sp) 
                 ) 
                 (if tf 
                   (setq vec (mapcar '- vec)) 
                   t 
                 ) 
                 (Pnt:DrawArrow sp vec) 
                 (progn (and isclosed (progn (grdraw sp ep 1 -1) t)) t) 
            ) 
          ) 
          (if 
            (and sp 
                 (setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: ")) 
                 (setq tdis (Curve:GetDistAt e dp)) 
                 (setq d (car (trans (mapcar '- dp sp) 0 vec))) 
                 (cond ((or (equal d 0.0 1e-3) (Curve:IsOn e dp)) 
                        (setq mod (+ mod 16)) 
                       ) 
                       ((> d 0.0) (setq mod (+ mod 8))) 
                       (t (setq mod (+ mod 32))) 
                 ) 
                 (if isclosed 
                   (if (or (< sdis tdis edis) (> sdis tdis edis)) 
                     (setq nl (XD::Geom:NumDiv edis sdis $dis)) 
                     (setq nl (XD::Geom:NumDiv 
                                edis 
                                sdis 
                                (list (curve:length e) $dis) 
                              ) 
                     ) 
                   ) 
                   (if (or (< sdis tdis edis) (> sdis tdis edis)) 
                     (setq nl (XD::Geom:NumDiv edis sdis $dis)) 
                   ) 
                 ) 
            ) 
             (progn (fy:begin) 
                    (setq pts (mapcar '(lambda (x / v) 
                                         (setq v (Curve:GetFirstDeriv e x)) 
                                         (list (vlax-curve-getpointatdist e x) 
                                               (if tf 
                                                 (mapcar '- v) 
                                                 v 
                                               ) 
                                         ) 
                                       ) 
                                      nl 
                              ) 
                          ptl (mapcar '(lambda (x) (apply 'GetArcPoints x)) pts) 
                    ) 
                    (mapcar '(lambda (x) (apply 'Arc:3pMake x)) ptl) 
                    (redraw) 
                    (fy:end) 
             ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
)

lucas3 · 发表于 2014-9-15 08:31:08

Free-Lancer 发表于 2014-9-15 07:37
如 st788796 所言，调整两句话既可，更新 lib.vlx 将 Curve:IsOn 加入

Free-Lancer大师，辛苦了！圆弧反向的问题完美解决，体验非常完美！谢谢！
您也是起床好早呀，看您也经常晚睡早起，请爱惜身体呀！{:soso_e183:}

st788796 · 发表于 2014-9-15 08:34:14

lucas3 发表于 2014-9-15 08:31
Free-Lancer大师，辛苦了！圆弧反向的问题完美解决，体验非常完美！谢谢！
您也是起床好早呀，看您也经 ...

给大家 Show 个演示吧

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

st788796 发表于 2014-9-15 08:34
给大家 Show 个演示吧

哈哈，可以的，情况分好多种，中午空闲时做一个比较典型示例的演示吧

lucas3 · 发表于 2014-9-15 13:46:23

本帖最后由 lucas3 于 2014-9-15 13:47 编辑

st788796 发表于 2014-9-15 08:34
给大家 Show 个演示吧

登录/注册后可看大图

lucas3 · 发表于 2014-9-15 13:47:53

登录/注册后可看大图

lucas3 · 发表于 2014-9-15 13:48:26

登录/注册后可看大图

lucas3 · 发表于 2014-9-15 13:49:21

登录/注册后可看大图

csharp · 发表于 2014-9-15 16:09:34

lucas3 发表于 2014-9-15 13:49

方向提示很人性化，演示做的也不错

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

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

点评

评分

点评

点评

点评

点评

点评