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

st788796 · 发表于 2014-9-13 16:23:49

lucas3 发表于 2014-9-13 16:10
谢谢！辛苦了！
下面两个问题解决了
强烈请求 Free-Lancer大师考虑一下更换 ...

对话框可仅保留正反、及居中, 左右在程序中点取

lucas3 · 发表于 2014-9-13 16:29:36

st788796 发表于 2014-9-13 16:23
对话框可仅保留正反、及居中, 左右在程序中点取

正反不好区分吧，像圆这种封闭图形，能不能在程序中做到就像选择方向那样根据箭头选择是哪一侧？

Free-Lancer · 发表于 2014-9-13 17:19:24

lucas3 发表于 2014-9-13 16:29
正反不好区分吧，像圆这种封闭图形，能不能在程序中做到就像选择方向那样根据箭头选择是哪一侧？

正反指圆弧按前进方向是向前凸还是向后凹，既然不好理解左右，那就简化成这样

XDSoft · 发表于 2014-9-13 17:38:04

Free-Lancer 发表于 2014-9-13 17:19
正反指圆弧按前进方向是向前凸还是向后凹，既然不好理解左右，那就简化成这样

圆弧还是用逆时针还是顺时针方便。

lucas3 · 发表于 2014-9-13 20:11:43

Free-Lancer 发表于 2014-9-13 17:19
正反指圆弧按前进方向是向前凸还是向后凹，既然不好理解左右，那就简化成这样

Free-Lancer 大师，圆弧的方向是靠起点至终点的决点的吗？具体怎么好弄，还是以您的为准，只要好分辨，一次都能够画准。

Free-Lancer · 发表于 2014-9-14 11:32:53

本帖最后由 Free-Lancer 于 2014-9-14 11:35 编辑

lucas3 发表于 2014-9-13 20:11
Free-Lancer 大师，圆弧的方向是靠起点至终点的决点的吗？具体怎么好弄，还是以您的为准，只要好分辨，一 ...

大体这样，还有几处关系没有搞对, lib.vlx 已更新

;; fron --- 2 back --- 4
;; left --- 8 mid --- 16 right 32
(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 (/ IsClosed GetArcPoints slbname slst
params str fn id e sp ep
lst n nl pts ptl dist cedis
csdis sdis edis tdis tp key mod
$dis result
)
(defun pnt:drawcrosshair (p col /)
(grvecs
(list col
(polar p (/ pi 4) (* (getvar "viewsize") 0.05))
(polar p (* pi 1.25) (* (getvar "viewsize") 0.05))
col
(polar p (* pi 0.75) (* (getvar "viewsize") 0.05))
(polar p (* pi -0.25) (* (getvar "viewsize") 0.05))
)
)
t
)
(defun GetDrawSide (bp v / bp)
(if (setq p (getpoint bp "\n在绘制一侧点击: "))
(car (trans (mapcar '- p bp) 0 v))
)
)
(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 p tf / v an p1 p2 p3 d1)
(setq v (vlax-curve-getfirstderiv
e
(vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e p)
)
)
)
(if tf
t
(setq v (mapcar '- v))
)
(setq an (angle '(0. 0. 0.) v)
p1 (polar p an (* 0.25 (getvar "viewsize")))
p2 (polar p1 (+ an (* 1.25 pi)) (/ (distance p p1) 6.))
p3 (polar p1 (- an (* 1.25 pi)) (/ (distance p 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
((= mod 10) ;_ 2 + 8
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 18) ;_2 + 16
(setq tp (polar p (+ pi an) w4)
p2 (polar tp an1 w2)
p1 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 34) ;_ 2 + 32
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 12) ;_ 4 + 8
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) (+ pi an) w4)
)
(list p p1 p2)
)
((= mod 20) ;_ 4 + 16
(setq tp (polar p (+ pi an) w4)
p1 (polar tp an1 w2)
p2 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 36) ;_ 4 + 32
(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) ;_写出临时 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 格式按钮默认值
(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
(setq result (dcl:start id fn))
;;Main program
(if (= result 1) ;_ok
(progn
(if (= $globle_mode "fmid")
(setq mod 2)
(setq mod 4)
)
(pnt:drawcrosshair (vlax-curve-getstartpoint e) 1)
(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 (or (not key) (= key ""))
(setq nl (XD::Geom:NumDiv cedis 0.0 $dis))
(setq nl (XD::Geom:NumDiv 0.0 cedis $dis)) ;_正向
)
)
(if
(and
(setq sp (getpoint "\n起点: "))
(pnt:drawcrosshair sp 3)
(setq ep (getpoint sp "\n终点: "))
(pnt:drawcrosshair ep 3)
(setq sdis (GetDistAtPoint e sp)
edis (GetDistAtPoint e ep)
)
(progn
(and (isclosed e)
(progn
(grdraw sp ep 1 -1)
t
)
)
t
)
(DrawDirct e
sp
(if (> sdis edis)
nil
t
)
)
(setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: "))
(setq tdis (GetDistAtPoint e dp))
(setq vec (vlax-curve-getfirstderiv
e
(vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e sp)
)
)
d (car (trans (mapcar '- dp sp) 0 vec))
)
(cond
((equal d 0.0 1e-3) (setq mod (+ mod 16)))
((> d 0.0) (setq mod (+ mod 8))) ;_left
(t (setq mod (+ mod 32))) ;_right
) ;_middle
(if (isclosed e)
(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 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
)
(redraw)
;(fy:end)
)
)
)
)
)
)
)
(princ)
)

;; fron --- 2 back --- 4 
;; left --- 8 mid  --- 16  right 32 
(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 (/             IsClosed             GetArcPoints    slbname slst 
             params  str     fn             id             e             sp             ep 
             lst     n             nl             pts     ptl     dist    cedis 
             csdis   sdis    edis    tdis    tp             key     mod 
             $dis    result 
            ) 
  (defun pnt:drawcrosshair (p col /) 
    (grvecs 
      (list col 
            (polar p (/ pi 4) (* (getvar "viewsize") 0.05)) 
            (polar p (* pi 1.25) (* (getvar "viewsize") 0.05)) 
            col 
            (polar p (* pi 0.75) (* (getvar "viewsize") 0.05)) 
            (polar p (* pi -0.25) (* (getvar "viewsize") 0.05)) 
      ) 
    ) 
    t 
  ) 
  (defun GetDrawSide (bp v / bp) 
    (if        (setq p (getpoint bp "\n在绘制一侧点击: ")) 
      (car (trans (mapcar '- p bp) 0 v)) 
    ) 
  ) 
  (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 p tf / v an p1 p2 p3 d1) 
    (setq v (vlax-curve-getfirstderiv 
              e 
              (vlax-curve-getparamatpoint 
                e 
                (vlax-curve-getclosestpointto e p) 
              ) 
            ) 
    ) 
    (if        tf 
      t 
      (setq v (mapcar '- v)) 
    ) 
    (setq an (angle '(0. 0. 0.) v) 
          p1 (polar p an (* 0.25 (getvar "viewsize"))) 
          p2 (polar p1 (+ an (* 1.25 pi)) (/ (distance p p1) 6.)) 
          p3 (polar p1 (- an (* 1.25 pi)) (/ (distance p 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 
      ((= mod 10) ;_ 2 + 8 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) an w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= mod 18) ;_2 + 16 
       (setq tp        (polar p (+ pi an) w4) 
             p2        (polar tp an1 w2) 
             p1        (polar tp (+ pi an1) w2) 
       ) 
       (list p1 p p2) 
      ) 
      ((= mod 34) ;_ 2 + 32 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) an w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= mod 12) ;_ 4 + 8 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) (+ pi an) w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= mod 20) ;_ 4 + 16 
       (setq tp        (polar p (+ pi an) w4) 
             p1        (polar tp an1 w2) 
             p2        (polar tp (+ pi an1) w2) 
       ) 
       (list p1 p p2) 
      ) 
      ((= mod 36) ;_ 4 + 32 
       (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) ;_写出临时 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 格式按钮默认值 
      (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 
      (setq result (dcl:start id fn)) 
      ;;Main program 
      (if (= result 1) ;_ok 
        (progn 
          (if (= $globle_mode "fmid") 
            (setq mod 2) 
            (setq mod 4) 
          ) 
          (pnt:drawcrosshair (vlax-curve-getstartpoint e) 1) 
          (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 (or (not key) (= key "")) 
                (setq nl (XD::Geom:NumDiv cedis 0.0 $dis)) 
                (setq nl (XD::Geom:NumDiv 0.0 cedis $dis)) ;_正向 
              ) 
            ) 
            (if 
              (and 
                (setq sp (getpoint "\n起点: ")) 
                (pnt:drawcrosshair sp 3) 
                (setq ep (getpoint sp "\n终点: ")) 
                (pnt:drawcrosshair ep 3) 
                (setq sdis (GetDistAtPoint e sp) 
                      edis (GetDistAtPoint e ep) 
                ) 
                (progn 
                  (and (isclosed e) 
                       (progn 
                         (grdraw sp ep 1 -1) 
                         t 
                       ) 
                  ) 
                  t 
                ) 
                (DrawDirct e 
                           sp 
                           (if (> sdis edis) 
                             nil 
                             t 
                           ) 
                ) 
                (setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: ")) 
                (setq tdis (GetDistAtPoint e dp)) 
                (setq vec (vlax-curve-getfirstderiv 
                            e 
                            (vlax-curve-getparamatpoint 
                              e 
                              (vlax-curve-getclosestpointto e sp) 
                            ) 
                          ) 
                      d          (car (trans (mapcar '- dp sp) 0 vec)) 
                ) 
                (cond 
                  ((equal d 0.0 1e-3) (setq mod (+ mod 16))) 
                  ((> d 0.0) (setq mod (+ mod 8))) ;_left 
                  (t (setq mod (+ mod 32))) ;_right 
                ) ;_middle 
                (if (isclosed e) 
                  (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 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 
                 ) 
                 (redraw) 
                                        ;(fy:end) 
               ) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
)

st788796 · 发表于 2014-9-14 12:16:08

Free-Lancer 发表于 2014-9-14 11:32
大体这样，还有几处关系没有搞对, lib.vlx 已更新

当 sp ep获取先后与线起止方向反向时 vec 变量应为负向量，闭合线判断不全

Free-Lancer · 发表于 2014-9-14 14:51:22

情况很多，就测试了几种

;; fron --- 2 back --- 4
;; left --- 8 mid --- 16 right 32
(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
)
;;返回点对应 ARC 三点参数
(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) ;_ 2 + 8
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 18) ;_2 + 16
(setq tp (polar p (+ pi an) w4)
p2 (polar tp an1 w2)
p1 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 34) ;_ 2 + 32
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) an w4)
)
(list p p1 p2)
)
((= mod 12) ;_ 4 + 8
(setq p2 (polar p an1 $globle_wid)
p1 (polar (fy:midp p p2) (+ pi an) w4)
)
(list p p1 p2)
)
((= mod 20) ;_ 4 + 16
(setq tp (polar p (+ pi an) w4)
p1 (polar tp an1 w2)
p2 (polar tp (+ pi an1) w2)
)
(list p1 p p2)
)
((= mod 36) ;_ 4 + 32
(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)
)
(if (= $globle_totle "1")
(progn
(setq vec (Curve:GetFirstDeriv e startpoint)
len (Curve:Length e)
sp startpoint
)
(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
edis len
)
(progn
(redraw)
(setq ep (vlax-curve-getendpoint e))
(Pnt:DrawArrow ep (mapcar '- vec))
(setq sdis len
edis 0.0
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:GetDistAtPoint e sp)
edis (Curve:GetDistAtPoint 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
sdis
edis
(setq mod
(if (not tf)
(if (= $globle_mode "fmid")
2
4
)
(if (= $globle_mode "fmid")
4
2
)
)
)
(setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: "))
(setq tdis (Curve:GetDistAtPoint e dp))
(setq d (car (trans (mapcar '- dp sp) 0 vec)))
(cond
((equal d 0.0 1e-3) (setq mod (+ mod 16)))
((> d 0.0) (setq mod (+ mod 8))) ;_left
(t (setq mod (+ mod 32))) ;_right
) ;_middle
(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 (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 x)
)
pts
)
)
(mapcar '(lambda (x) (apply 'Arc:3pMake x))
ptl
)
(redraw)
;;(fy:end)
)
)
)
)
)
)
(princ)
)
;;====
(defun Pnt:Mark (p col / p1 p2 p3 p4)
(grvecs
(list col
(polar p (/ pi 4) (* (getvar "viewsize") 0.05))
(polar p (* pi 1.25) (* (getvar "viewsize") 0.05))
col
(polar p (* pi 0.75) (* (getvar "viewsize") 0.05))
(polar p (* pi -0.25) (* (getvar "viewsize") 0.05))
col
(setq p1 (polar p (* pi 0.75) (* (getvar "viewsize") 0.025)))
(setq p2 (polar p (/ pi 4) (* (getvar "viewsize") 0.025)))
col
p2
(setq p3 (polar p (* pi -0.25) (* (getvar "viewsize") 0.025)))
col
p3
(setq p4 (polar p (* pi 1.25) (* (getvar "viewsize") 0.025)))
col
p4
p1
)
)
t
)
(defun Pnt:DrawCrossHair (p col /)
(grvecs
(list col
(polar p (/ pi 4) (* (getvar "viewsize") 0.05))
(polar p (* pi 1.25) (* (getvar "viewsize") 0.05))
col
(polar p (* pi 0.75) (* (getvar "viewsize") 0.05))
(polar p (* pi -0.25) (* (getvar "viewsize") 0.05))
)
)
t
)
(defun Pnt:DrawArrow (p v / an p1 p2 p3)
(setq an (angle '(0. 0. 0.) v)
p1 (polar p an (* 0.25 (getvar "viewsize")))
p2 (polar p1 (+ an (* 0.833333 pi)) (/ (distance p p1) 6.))
p3 (polar p1 (- an (* 0.833333 pi)) (/ (distance p p1) 6.))
)
(grvecs (list 1 p p1 1 p1 p2 1 p1 p3))
t
)
(defun Curve:GetDistAtPoint (e p)
(vlax-curve-getdistatpoint
e
(vlax-curve-getclosestpointto e p)
)
)
(defun Curve:GetParamAtPoint (e p)
(vlax-curve-getparamatpoint
e
(vlax-curve-getclosestpointto e p)
)
)
(defun Curve:GetFirstDeriv (e p)
(vlax-curve-getfirstderiv e (Curve:GetParamAtPoint e p))
)
(defun Curve:Length (e)
(vlax-curve-getdistatparam e (vlax-curve-getendparam e))
)
(defun Curve:IsClosed (e)
(or (vlax-curve-isclosed e)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
1e-3
)
)
)

;; fron --- 2 back --- 4 
;; left --- 8 mid  --- 16  right 32 
(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 
            ) 
  ;;返回点对应 ARC 三点参数 
  (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) ;_ 2 + 8 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) an w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= mod 18) ;_2 + 16 
       (setq tp        (polar p (+ pi an) w4) 
             p2        (polar tp an1 w2) 
             p1        (polar tp (+ pi an1) w2) 
       ) 
       (list p1 p p2) 
      ) 
      ((= mod 34) ;_ 2 + 32 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) an w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= mod 12) ;_ 4 + 8 
       (setq p2        (polar p an1 $globle_wid) 
             p1        (polar (fy:midp p p2) (+ pi an) w4) 
       ) 
       (list p p1 p2) 
      ) 
      ((= mod 20) ;_ 4 + 16 
       (setq tp        (polar p (+ pi an) w4) 
             p1        (polar tp an1 w2) 
             p2        (polar tp (+ pi an1) w2) 
       ) 
       (list p1 p p2) 
      ) 
      ((= mod 36) ;_ 4 + 32 
       (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) 
          ) 
          (if (= $globle_totle "1") 
            (progn 
              (setq vec        (Curve:GetFirstDeriv e startpoint) 
                    len        (Curve:Length e) 
                    sp        startpoint 
              ) 
              (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 
                      edis len 
                ) 
                (progn 
                  (redraw) 
                  (setq ep (vlax-curve-getendpoint e)) 
                  (Pnt:DrawArrow ep (mapcar '- vec)) 
                  (setq        sdis len 
                        edis 0.0 
                        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:GetDistAtPoint e sp) 
                       edis (Curve:GetDistAtPoint 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 
              sdis 
              edis 
              (setq mod 
                     (if (not tf) 
                       (if (= $globle_mode "fmid") 
                         2 
                         4 
                       ) 
                       (if (= $globle_mode "fmid") 
                         4 
                         2 
                       ) 
                     ) 
              ) 
              (setq dp (getpoint sp "\n点击标注一侧<以切线为基准>: ")) 
              (setq tdis (Curve:GetDistAtPoint e dp)) 
              (setq d (car (trans (mapcar '- dp sp) 0 vec))) 
              (cond 
                ((equal d 0.0 1e-3) (setq mod (+ mod 16))) 
                ((> d 0.0) (setq mod (+ mod 8))) ;_left 
                (t (setq mod (+ mod 32))) ;_right 
              ) ;_middle 
              (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 (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 x) 
                                  ) 
                                 pts 
                         ) 
               ) 
               (mapcar '(lambda (x) (apply 'Arc:3pMake x)) 
                       ptl 
               ) 
               (redraw) 
               ;;(fy:end) 
             ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
;;==== 
(defun Pnt:Mark        (p col / p1 p2 p3 p4) 
  (grvecs 
    (list col 
          (polar p (/ pi 4) (* (getvar "viewsize") 0.05)) 
          (polar p (* pi 1.25) (* (getvar "viewsize") 0.05)) 
          col 
          (polar p (* pi 0.75) (* (getvar "viewsize") 0.05)) 
          (polar p (* pi -0.25) (* (getvar "viewsize") 0.05)) 
          col 
          (setq p1 (polar p (* pi 0.75) (* (getvar "viewsize") 0.025))) 
          (setq p2 (polar p (/ pi 4) (* (getvar "viewsize") 0.025))) 
          col 
          p2 
          (setq p3 (polar p (* pi -0.25) (* (getvar "viewsize") 0.025))) 
          col 
          p3 
          (setq p4 (polar p (* pi 1.25) (* (getvar "viewsize") 0.025))) 
          col 
          p4 
          p1 
    ) 
  ) 
  t 
) 
(defun Pnt:DrawCrossHair (p col /) 
  (grvecs 
    (list col 
          (polar p (/ pi 4) (* (getvar "viewsize") 0.05)) 
          (polar p (* pi 1.25) (* (getvar "viewsize") 0.05)) 
          col 
          (polar p (* pi 0.75) (* (getvar "viewsize") 0.05)) 
          (polar p (* pi -0.25) (* (getvar "viewsize") 0.05)) 
    ) 
  ) 
  t 
) 
(defun Pnt:DrawArrow (p v / an p1 p2 p3) 
  (setq        an (angle '(0. 0. 0.) v) 
        p1 (polar p an (* 0.25 (getvar "viewsize"))) 
        p2 (polar p1 (+ an (* 0.833333 pi)) (/ (distance p p1) 6.)) 
        p3 (polar p1 (- an (* 0.833333 pi)) (/ (distance p p1) 6.)) 
  ) 
  (grvecs (list 1 p p1 1 p1 p2 1 p1 p3)) 
  t 
) 
(defun Curve:GetDistAtPoint (e p) 
  (vlax-curve-getdistatpoint 
    e 
    (vlax-curve-getclosestpointto e p) 
  ) 
) 
(defun Curve:GetParamAtPoint (e p) 
  (vlax-curve-getparamatpoint 
    e 
    (vlax-curve-getclosestpointto e p) 
  ) 
) 
(defun Curve:GetFirstDeriv (e p) 
  (vlax-curve-getfirstderiv e (Curve:GetParamAtPoint e p)) 
) 
(defun Curve:Length (e) 
  (vlax-curve-getdistatparam e (vlax-curve-getendparam e)) 
) 
(defun Curve:IsClosed (e) 
  (or (vlax-curve-isclosed e) 
      (equal (vlax-curve-getstartpoint e) 
             (vlax-curve-getendpoint e) 
             1e-3 
      ) 
  ) 
)

st788796 · 发表于 2014-9-14 15:55:44

Free-Lancer 发表于 2014-9-14 14:51
情况很多，就测试了几种

整线时反向不能直接负，要取 endpoint 的 firstderiv , 后面的 mod 也不用 if if ....

Free-Lancer · 发表于 2014-9-14 16:50:18

st788796 发表于 2014-9-14 15:55
整线时反向不能直接负，要取 endpoint 的 firstderiv , 后面的 mod 也不用 if if ....

这回好像都对了

(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 (+ pi 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 '- v)
sp ep
)
)
)
)
(and (setq sp (getpoint "\n起点: "))
(Pnt:Mark sp 1)
(setq ep (getpoint sp "\n终点: "))
(Pnt:DrawCrossHair ep 3)
(setq sdis (Curve:GetDistAtPoint e sp)
edis (Curve:GetDistAtPoint 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:GetDistAtPoint e dp))
(setq d (car (trans (mapcar '- dp sp) 0 vec)))
(cond
((equal d 0.0 1e-3) (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 (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 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 (+ pi 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 '- v) 
                        sp   ep 
                  ) 
                ) 
              ) 
            ) 
            (and (setq sp (getpoint "\n起点: ")) 
                 (Pnt:Mark sp 1) 
                 (setq ep (getpoint sp "\n终点: ")) 
                 (Pnt:DrawCrossHair ep 3) 
                 (setq sdis (Curve:GetDistAtPoint e sp) 
                       edis (Curve:GetDistAtPoint 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:GetDistAtPoint e dp)) 
              (setq d (car (trans (mapcar '- dp sp) 0 vec))) 
              (cond 
                ((equal d 0.0 1e-3) (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 (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 x) 
                                  ) 
                                 pts 
                         ) 
               ) 
               (mapcar '(lambda (x) (apply 'Arc:3pMake x)) 
                       ptl 
               ) 
               (redraw) 
               (fy:end) 
             ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
)

lucas3 · 发表于 2014-9-14 17:07:22

Free-Lancer 发表于 2014-9-14 14:51
情况很多，就测试了几种

大师，就拿了一条直线测试都没成功，选择点对点绘制，左至右选点，方向为前凸，然后选择点取标注一侧，选择直线下方，它一样绘制在上方
同样的，选点对点绘制，左至右选点，选择后凹，然后选择点取标注一侧，选点在直线上，结果还是前凸

lucas3 · 发表于 2014-9-14 17:08:44

Free-Lancer 发表于 2014-9-14 16:50
这回好像都对了

谢谢，{:soso_e161:}待会再测试

Free-Lancer · 发表于 2014-9-14 17:53:34

lucas3 发表于 2014-9-14 17:08
谢谢，待会再测试

更新 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" "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 (+ pi 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 '- v)
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
((equal d 0.0 1e-3) (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 (+ pi 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 '- v) 
                        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 
                ((equal d 0.0 1e-3) (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-14 18:42:08

本帖最后由 lucas3 于 2014-9-14 18:53 编辑

Free-Lancer 发表于 2014-9-14 17:53
更新 lib.vlx

大师，又更新呢？
还是以直线测试，整线布置，选择是否反向，选择“是”，结果就是错误: 参数类型错误: 坐标系定义: nil

点击标注一侧<以切线为基准>: ; 错误: 参数类型错误: 坐标系定义: nil

复制代码

直线测试，选择后凹，起点在左，终点在右，如果布置在直线两侧，弧的方向对了，如果布置在直线上，方向又错了！

st788796 · 发表于 2014-9-14 18:58:20

= 10 不对

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

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

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评