[API应用]画线标注

st788796 · 发表于 2016-5-25 09:49:40

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

测试

(defun c:tt (/ ss p1 p2 v _inters p an)
(defun _inters (p1 p2 e / pts ln2d gelst com2d typ ptl)
(if (and (setq typ (car (xdrx_getpropertyvalue e "ClassName")))
(setq ln2d (xdge::constructor "kLineSeg2d" p1 p2))
)
(progn
(cond
((= typ "HATCH") (setq pts (xdrx_geom_searchoutline e)))
((= typ "INSERT") (setq pts (xdrx_entity_box e)))
(t)
)
(and pts
(setq gelst (mapcar '(lambda (x) (xdge::constructor "kLineSeg2d" (car x) (cadr x)))
(xd::list:snakepair (xd::pnts:close pts))
)
)
(setq com2d (xdge::constructor "kCompositeCrv2d" gelst))
(setq cc (xdge::constructor "kCurveCurveInt2d" ln2d com2d)
n -1
)
(repeat (xdge::getpropertyvalue cc "numIntPoints")
(setq ptl (cons (xdge::getpropertyvalue cc "intPoint" (setq n (1+ n))) ptl))
)
)
)
)
(xdge::free)
(setq v (mapcar '- p2 p1))
ptl
)
(defun _sort (p1 p2 ptl / v)
(setq v (mapcar '- p2 p1))
(vl-sort ptl
'(lambda (x1 x2)
(< (last (trans (mapcar '- x1 p1) 0 v))
(last (trans (mapcar '- x2 p1) 0 v))
)
)
)
)
(if (and (setq p1 (getpoint "\nFirst Point: "))
(setq p2 (getpoint p1 "\nSecond Point: "))
(if (> (angle p1 p2) _pi2)
(mapcar 'set '(p1 p2) (list p2 p1))
t
)
(xdrx_grdraw 1 p1 p2)
(setq v (xd::doc:getdist p1 nil nil (mapcar '- p2 p1) t))
(setq ss (ssget "F" (list p1 p2) '((0 . "*line,arc,circle,ellipse,insert,hatch"))))
)
(progn
(setq
lst (_sort
p1
p2
(xd::list:removedup
(apply 'append
(mapcar '(lambda (x)
(if (member (car (xdrx_getpropertyvalue (cadr x) "ClassName")) '("HATCH" "INSERT"))
(_inters p1 p2 (cadr x))
(mapcar 'cadr (cdddr x))
)
)
(ssnamex ss)
)
)
)
)
p (mapcar '+ p1 v)
an (angle p1 p2)
)
(mapcar '(lambda (a b)
(xdrx_dimension_makerotate a b (mapcar '+ a v) an)
)
lst
(cdr lst)
)
)
)
(princ)
)

(defun c:tt (/ ss p1 p2 v _inters p an) 
  (defun _inters (p1 p2 e / pts ln2d gelst com2d typ ptl) 
    (if        (and (setq typ (car (xdrx_getpropertyvalue e "ClassName"))) 
             (setq ln2d (xdge::constructor "kLineSeg2d" p1 p2)) 
        ) 
      (progn 
        (cond 
          ((= typ "HATCH") (setq pts (xdrx_geom_searchoutline e))) 
          ((= typ "INSERT") (setq pts (xdrx_entity_box e))) 
          (t) 
        ) 
        (and pts 
             (setq gelst (mapcar '(lambda (x) (xdge::constructor "kLineSeg2d" (car x) (cadr x))) 
                                 (xd::list:snakepair (xd::pnts:close pts)) 
                         ) 
             ) 
             (setq com2d (xdge::constructor "kCompositeCrv2d" gelst)) 
             (setq cc (xdge::constructor "kCurveCurveInt2d" ln2d com2d) 
                   n  -1 
             ) 
             (repeat (xdge::getpropertyvalue cc "numIntPoints") 
               (setq ptl (cons (xdge::getpropertyvalue cc "intPoint" (setq n (1+ n))) ptl)) 
             ) 
        ) 
      ) 
    ) 
    (xdge::free) 
    (setq v (mapcar '- p2 p1)) 
    ptl 
  ) 
  (defun _sort (p1 p2 ptl / v) 
    (setq v (mapcar '- p2 p1)) 
    (vl-sort ptl 
             '(lambda (x1 x2) 
                (< (last (trans (mapcar '- x1 p1) 0 v)) 
                   (last (trans (mapcar '- x2 p1) 0 v)) 
                ) 
              ) 
    ) 
  ) 
  (if (and (setq p1 (getpoint "\nFirst Point: ")) 
           (setq p2 (getpoint p1 "\nSecond Point: ")) 
           (if (> (angle p1 p2) _pi2) 
             (mapcar 'set '(p1 p2) (list p2 p1)) 
             t 
           ) 
           (xdrx_grdraw 1 p1 p2) 
           (setq v (xd::doc:getdist p1 nil nil (mapcar '- p2 p1) t)) 
           (setq ss (ssget "F" (list p1 p2) '((0 . "*line,arc,circle,ellipse,insert,hatch")))) 
      ) 
    (progn 
      (setq 
        lst (_sort 
              p1 
              p2 
              (xd::list:removedup 
                (apply 'append 
                       (mapcar '(lambda        (x) 
                                  (if (member (car (xdrx_getpropertyvalue (cadr x) "ClassName")) '("HATCH" "INSERT")) 
                                    (_inters p1 p2 (cadr x)) 
                                    (mapcar 'cadr (cdddr x)) 
                                  ) 
                                ) 
                               (ssnamex ss) 
                       ) 
                ) 
              ) 
            ) 
        p   (mapcar '+ p1 v) 
        an  (angle p1 p2) 
      ) 
      (mapcar '(lambda (a b) 
                 (xdrx_dimension_makerotate a b (mapcar '+ a v) an) 
               ) 
              lst 
              (cdr lst) 
      ) 
    ) 
  ) 
  (princ) 
)

Lisphk · 发表于 2016-5-25 11:04:54

提供下测试结果，发现两种情况需要改进

1、填充给标注的时候，基线的位置不对
2、基线位置对的时候填充没给标注

看图
选线标注测试.gif

st788796 · 发表于 2016-5-25 13:07:28

不知是系统原因还是API原因，再使用时Autocad崩溃了，排查中

st788796 · 发表于 2016-5-25 15:25:19

Lisphk 发表于 2016-5-25 11:04
提供下测试结果，发现两种情况需要改进

1、填充给标注的时候，基线的位置不对

这样改了下，很奇怪 Hatch 时灵时不灵

(defun c:tt (/ ss p1 p2 v _inters p an)
(defun _inters (p1 p2 e / pts)
(if (setq pts (xdrx_geom_searchoutline e))
(xdrx_curve_getinters (list p1 p2) (xd::pnts:setz pts 0.0))
)
)
(defun _sort (p1 p2 ptl / v)
(setq v (mapcar '- p2 p1))
(vl-sort ptl
'(lambda (x1 x2)
(< (last (trans (mapcar '- x1 p1) 0 v))
(last (trans (mapcar '- x2 p1) 0 v))
)
)
)
)
(if (and (setq p1 (getpoint "\nFirst Point: "))
(setq p2 (getpoint p1 "\nSecond Point: "))
(if (< _pi2 (angle p1 p2) (* pi 1.5))
(mapcar 'set '(p1 p2) (list p2 p1))
t
)
(xdrx_grdraw 1 p1 p2)
(setq v (xd::doc:getdist p1 nil nil (mapcar '- p2 p1) t))
(setq ss (ssget "F" (list p1 p2) '((0 . "*line,arc,circle,ellipse,insert,hatch"))))
)
(progn
(setq
lst (_sort
p1
p2
(xd::list:removedup
(apply 'append
(mapcar '(lambda (x)
(if (member (car (xdrx_getpropertyvalue (cadr x) "ClassName")) '("HATCH" "INSERT"))
(_inters p1 p2 (cadr x))
(mapcar 'cadr (cdddr x))
)
)
(ssnamex ss)
)
)
)
)
p (mapcar '+ p1 v)
an (angle p1 p2)
)
(mapcar '(lambda (a b)
(xdrx_dimension_makerotate a b (mapcar '+ a v) an)
)
lst
(cdr lst)
)
)
)
(princ)
)

(defun c:tt (/ ss p1 p2 v _inters p an) 
  (defun _inters (p1 p2 e / pts) 
    (if        (setq pts (xdrx_geom_searchoutline e)) 
      (xdrx_curve_getinters (list p1 p2) (xd::pnts:setz pts 0.0)) 
    ) 
  ) 
  (defun _sort (p1 p2 ptl / v) 
    (setq v (mapcar '- p2 p1)) 
    (vl-sort ptl 
             '(lambda (x1 x2) 
                (< (last (trans (mapcar '- x1 p1) 0 v)) 
                   (last (trans (mapcar '- x2 p1) 0 v)) 
                ) 
              ) 
    ) 
  ) 
  (if (and (setq p1 (getpoint "\nFirst Point: ")) 
           (setq p2 (getpoint p1 "\nSecond Point: ")) 
           (if (< _pi2 (angle p1 p2) (* pi 1.5)) 
             (mapcar 'set '(p1 p2) (list p2 p1)) 
             t 
           ) 
           (xdrx_grdraw 1 p1 p2) 
           (setq v (xd::doc:getdist p1 nil nil (mapcar '- p2 p1) t)) 
           (setq ss (ssget "F" (list p1 p2) '((0 . "*line,arc,circle,ellipse,insert,hatch")))) 
      ) 
    (progn 
      (setq 
        lst (_sort 
              p1 
              p2 
              (xd::list:removedup 
                (apply 'append 
                       (mapcar '(lambda        (x) 
                                  (if (member (car (xdrx_getpropertyvalue (cadr x) "ClassName")) '("HATCH" "INSERT")) 
                                    (_inters p1 p2 (cadr x)) 
                                    (mapcar 'cadr (cdddr x)) 
                                  ) 
                                ) 
                               (ssnamex ss) 
                       ) 
                ) 
              ) 
            ) 
        p   (mapcar '+ p1 v) 
        an  (angle p1 p2) 
      ) 
      (mapcar '(lambda (a b) 
                 (xdrx_dimension_makerotate a b (mapcar '+ a v) an) 
               ) 
              lst 
              (cdr lst) 
      ) 
    ) 
  ) 
  (princ) 
)

newer · 发表于 2016-5-25 15:40:18

st788796 发表于 2016-5-25 15:25
这样改了下，很奇怪 Hatch 时灵时不灵

那你在HATCH的代码下，加个打印语句，看看不灵的时候HATCH返回的内容是需要的不

137407536 · 发表于 2018-12-1 18:00:24

本帖最后由 137407536 于 2019-3-8 11:59 编辑

谢谢分享，学习了

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

[研讨] [API应用]画线标注

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评