如何实现选取边界自动偏移并插入块

偏爱云~小吴 · 发表于 2013-12-10 12:04

试搞了一下，搞不定请各位大神帮忙。如何实现选取矩形四边，然后自动偏移，然后标注ABCD，然后插入图示的2个块

1993063 · 发表于 2013-12-10 12:16

直线偏移方向不好控制

偏爱云~小吴 · 发表于 2013-12-10 12:20

是的，所以不好解决，大侠，有什么思路

偏爱云~小吴 · 发表于 2013-12-10 12:23

网上到是有个内偏的，但是处理的是连续

;;;******内缩偏移程序开始*****
(princ "\n★内缩偏移命令：ns ★\n")
(defun c:ns ()
(setvar "blipmode" 0)
(setvar "pickfirst" 1)
(setvar "osmode" 15359)
(setvar "cmdecho" 0)
(princ "\n★功能：批量将多段线、圆弧、圆进行内缩偏移.\n")
(command "ucs" "w")
(command "undo" "be")
(initget 6)
(setq dist (getreal "\n输入要内缩偏移的距离<0.004>："))
(if (not dist)
(setq dist 0.004)
)
(princ "\n选择要内缩偏移的对象：\n")
(setq ss (ssget '((0 . "CIRCLE,ARC,LWPOLYLINE"))))
(if (not ss)
(exit)
)
(setq num (sslength ss))
(setvar "osmode" 0)
(setq i 0
j 0
)
(command "LAYER" "M" "标记层" "C" "1" "标记层" "")
(command "LAYER" "M" "内缩" "C" "6" "内缩" "")
(vl-load-com)
(repeat num
(setq entnam (ssname ss i))
(setq obj (vlax-ename->vla-object entnam))
(setq len (vlax-curve-getdistatparam
obj
(vlax-curve-getendparam obj)
)
)
(vla-offset obj 0.00001)
(setq objlast (entlast))
(setq lenlast (vlax-curve-getdistatparam
objlast
(vlax-curve-getendparam objlast)
)
)
(entdel objlast)
(cond ((< lenlast len)
(progn
(vla-offset obj dist)
(setq en (entget (entlast)))
(entmod (subst (cons 8 "内缩") (assoc 8 en) en))
)
)
((> lenlast len)
(progn
(vla-offset obj (* -1 dist))
(setq en (entget (entlast)))
(entmod (subst (cons 8 "内缩") (assoc 8 en) en))
)
)
((= lenlast len)
(progn
(setq en (entget entnam))
(entmod (subst (cons 8 "标记层") (assoc 8 en) en))
(setq j (+ 1 j))
)
)
)
(setq i (1+ i))
)
(command "undo" "e")
(princ "\n★将选取对象进行内缩偏移成功.\n")
(if (> j 0) (princ (strcat "★提示：有" (itoa j) "个对象因无法判定偏移方向，未进行内缩偏移，已将其置于“标记层”。\n")))
(setvar "osmode" 15359)
(princ)
)
;;;******内缩偏移程序结束******

;;;******内缩偏移 程序开始***** 
(princ "\n★内缩偏移命令：ns ★\n") 
(defun c:ns () 
  (setvar "blipmode" 0) 
  (setvar "pickfirst" 1) 
  (setvar "osmode" 15359) 
  (setvar "cmdecho" 0) 
  (princ "\n★功能：批量将多段线、圆弧、圆进行内缩偏移.\n") 
  (command "ucs" "w") 
  (command "undo" "be") 
  (initget 6) 
  (setq dist (getreal "\n输入要内缩偏移的距离<0.004>：")) 
  (if (not dist) 
    (setq dist 0.004) 
  ) 
  (princ "\n选择要内缩偏移的对象：\n") 
  (setq ss (ssget '((0 . "CIRCLE,ARC,LWPOLYLINE")))) 
  (if (not ss) 
    (exit) 
  ) 
  (setq num (sslength ss)) 
  (setvar "osmode" 0) 
  (setq        i 0 
        j 0 
  ) 
  (command "LAYER" "M" "标记层" "C" "1" "标记层" "") 
  (command "LAYER" "M" "内缩" "C" "6" "内缩" "") 
  (vl-load-com) 
  (repeat num 
    (setq entnam (ssname ss i)) 
    (setq obj (vlax-ename->vla-object entnam)) 
    (setq len (vlax-curve-getdistatparam 
                obj 
                (vlax-curve-getendparam obj) 
              ) 
    ) 
    (vla-offset obj 0.00001) 
    (setq objlast (entlast)) 
    (setq lenlast (vlax-curve-getdistatparam 
                    objlast 
                    (vlax-curve-getendparam objlast) 
                  ) 
    ) 
    (entdel objlast) 
    (cond ((< lenlast len) 
           (progn 
             (vla-offset obj dist) 
             (setq en (entget (entlast))) 
             (entmod (subst (cons 8 "内缩") (assoc 8 en) en)) 
           ) 
          ) 
          ((> lenlast len) 
           (progn 
             (vla-offset obj (* -1 dist)) 
             (setq en (entget (entlast))) 
             (entmod (subst (cons 8 "内缩") (assoc 8 en) en)) 
           ) 
          ) 
          ((= lenlast len) 
           (progn 
             (setq en (entget entnam)) 
             (entmod (subst (cons 8 "标记层") (assoc 8 en) en)) 
             (setq j (+ 1 j)) 
           ) 
          ) 
    ) 
    (setq i (1+ i)) 
  ) 
  (command "undo" "e") 
  (princ "\n★将选取对象进行内缩偏移成功.\n") 
  (if (> j 0) (princ (strcat "★提示：有" (itoa j) "个对象因无法判定偏移方向，未进行内缩偏移，已将其置于“标记层”。\n"))) 
  (setvar "osmode" 15359) 
  (princ) 
) 
;;;******内缩偏移 程序结束******

的单条的线

偏爱云~小吴 · 发表于 2013-12-10 12:25

；；这个是处理块的

(defun c:dj ()
    (setq i 0)
    (setq pline (car (entsel)))
    (setq ent (entget pline))
    (setq pts nil)
    (repeat (length ent)
    (if (= (car (nth i ent)) 10)
;(setq pts (append pts (list (cdr (nth i ent)))))
(setq p0  (cdr (nth i ent)))
  (ins)
    )
    (setq i (1+ i))
  )
(entdel pline)
       (princ)
)
(defun ins ()
;(setq p1 (getpoint "\n梁内边左下端点为起点: "))
(COMMAND "-insert"  "点筋" p0 "1" "1" "0" )
(princ)
)

偏爱云~小吴 · 发表于 2013-12-10 12:27

(defun c:zm1 (/ mycopy mymove SstoEs sign ss p1 p2)
(defun SstoEs(ss / a en lst)
(if ss(progn(setq a -1)(while(setq en(ssname ss(setq a(1+ a))))(setq lst (cons en lst)))))
lst)
(defun sign (nn) (if (< nn 0) -1 (if (> nn 0) 1 0)))
(defun mycopy(ss p p1 / ty q q1 s1 s2);;参照by-xyp1964的xyp-ScaleEntity
(setq ty(type ss)i -1
s2(ssadd)
q1(vlax-3D-point(trans p1 0 0))
q(vlax-3D-point(trans p 0 0)))
(cond((= ty 'ENAME)(vla-move(vla-copy(vlax-ename->vla-object ss))q q1)(setq s2(ssadd(entlast)s2)))
((= ty 'PICKSET)
(setq i -1)
(while (setq s1 (ssname ss (setq i (1+ i))))
(mycopy s1 p p1)(setq s2(ssadd(entlast)s2))))
((= ty 'LIST)(foreach x ss(mycopy x p p1)(setq s2(ssadd(entlast)s2))))
)s2)
(defun mymove(ss p p1 / ty q q1 s1);;参照by-xyp1964的xyp-ScaleEntity
(setq ty(type ss)i -1
q1(vlax-3D-point(trans p1 0 0))
q(vlax-3D-point(trans p 0 0)))
(cond((= ty 'ENAME)(vla-move(vlax-ename->vla-object ss)q q1))
((= ty 'PICKSET)
(setq i -1)
(while (setq s1 (ssname ss (setq i (1+ i))))
(mymove s1 p p1)))
((= ty 'LIST)(foreach x ss(mymove x p p1))))
)
(setq ind (getint "\n输入增减量<1> :")
ind (sign ind))
(prompt"\n选择要进行递增复制的文字、属性")
(setq ss(SstoEs(ssget'((0 . "*TEXT,ATTDEF")))))
(setq p1(getpoint"复制基点"))
(setq p2(getpoint p1"复制到"))
(mycopy (setq ss(vl-remove'nil(mapcar'(lambda(x)(setq e(entget x))
(if(assoc 1 e)
(progn(setq tx(vl-string->list (cdr(assoc 1 e))))
(if(OR(<(IF(> ind 0)65 66)(last tx)(IF(> ind 0)89 90))
(<(IF(> ind 0)97 98)(last tx)(IF(> ind 0)121 122)))x))))ss)))p1 p1)
(mymove ss p1 p2)
(mapcar'(lambda(x)(entmod(setq e(entget x)
tx(vl-string->list (cdr(assoc 1 e)))
e(subst(cons 1 (vl-list->string(reverse(cons((IF(> ind 0)1+ 1-)(last tx))(cdr(reverse tx))))))(assoc 1 e)e)))
nil)ss)
(princ)
)
;;这个是字母递增复制，貌似ABCD直接写入也行

(defun c:zm1 (/ mycopy mymove SstoEs sign ss p1 p2) 
  (defun SstoEs(ss / a en lst) 
    (if ss(progn(setq a -1)(while(setq en(ssname ss(setq a(1+ a))))(setq lst (cons en lst))))) 
    lst) 
  (defun sign (nn) (if (< nn 0) -1 (if (> nn 0) 1 0))) 
  (defun mycopy(ss p p1 / ty q q1 s1 s2);;参照by-xyp1964的xyp-ScaleEntity 
    (setq ty(type ss)i -1 
    s2(ssadd) 
    q1(vlax-3D-point(trans p1 0 0)) 
    q(vlax-3D-point(trans p 0 0))) 
    (cond((= ty 'ENAME)(vla-move(vla-copy(vlax-ename->vla-object ss))q q1)(setq s2(ssadd(entlast)s2))) 
   ((= ty 'PICKSET) 
    (setq i -1) 
    (while (setq s1 (ssname ss (setq i (1+ i)))) 
      (mycopy s1 p p1)(setq s2(ssadd(entlast)s2)))) 
   ((= ty 'LIST)(foreach x ss(mycopy x p p1)(setq s2(ssadd(entlast)s2)))) 
   )s2) 
  (defun mymove(ss p p1 / ty q q1 s1);;参照by-xyp1964的xyp-ScaleEntity 
    (setq ty(type ss)i -1 
    q1(vlax-3D-point(trans p1 0 0)) 
    q(vlax-3D-point(trans p 0 0))) 
    (cond((= ty 'ENAME)(vla-move(vlax-ename->vla-object ss)q q1)) 
   ((= ty 'PICKSET) 
    (setq i -1) 
    (while (setq s1 (ssname ss (setq i (1+ i)))) 
      (mymove s1 p p1))) 
   ((= ty 'LIST)(foreach x ss(mymove x p p1)))) 
    ) 
  (setq ind (getint "\n输入增减量<1> :") 
        ind (sign ind)) 
  (prompt"\n选择要进行递增复制的文字、属性") 
  (setq ss(SstoEs(ssget'((0 . "*TEXT,ATTDEF"))))) 
  (setq p1(getpoint"复制基点")) 
  (setq p2(getpoint p1"复制到")) 
  (mycopy (setq ss(vl-remove'nil(mapcar'(lambda(x)(setq e(entget x)) 
      (if(assoc 1 e) 
        (progn(setq tx(vl-string->list (cdr(assoc 1 e)))) 
    (if(OR(<(IF(> ind 0)65 66)(last tx)(IF(> ind 0)89 90)) 
          (<(IF(> ind 0)97 98)(last tx)(IF(> ind 0)121 122)))x))))ss)))p1 p1) 
  (mymove ss p1 p2) 
  (mapcar'(lambda(x)(entmod(setq e(entget x) 
        tx(vl-string->list (cdr(assoc 1 e))) 
        e(subst(cons 1 (vl-list->string(reverse(cons((IF(> ind 0)1+ 1-)(last tx))(cdr(reverse tx))))))(assoc 1 e)e))) 
      nil)ss) 
 (princ) 
 ) 
;;这个是字母递增复制，貌似ABCD直接写入也行

q3_2006 · 发表于 2013-12-10 18:54

本帖最后由 q3_2006 于 2013-12-10 19:19 编辑

图块做得标准，这个很简单，但你的块也太随意了，还要计算插入点。。。另外，如果全部是矩形，只要做个动态块就搞定了。。不用写程序的。。。

偏爱云~小吴 · 发表于 2013-12-10 21:45

q3_2006 发表于 2013-12-10 18:54
图块做得标准，这个很简单，但你的块也太随意了，还要计算插入点。。。另外，如果全部是矩形，只要做个动态 ...

是啊，难就难在图形不是矩形而是四条线，大神有解么

偏爱云~小吴 · 发表于 2013-12-10 21:46

另外，插入点可以是直线的中点，计算中点应该难度会有所减小吧

偏爱云~小吴 · 发表于 2013-12-10 22:21

(defun c:tt (/ make-extline area d e npts pts tf tf1 an)
(defun make-extline (pts / ln ptl)
(setq ln (apply 'xdrx_line_make pts) ;创建LINE实体
ptl (xdrx_curve_getinters (ssname ln 0) (car e) 1) ;两个AcDbCurve(曲线)实体的交点
)
(xdrx_setpropertyvalue ;设置对象的属性值
(ssname ln 0)
"startpoint"
(car ptl)
"endpoint"
(cadr ptl)
)
)
(while
(and (setq e (xdrx_entsel "\nPick Pline: " '((0 . "*polyline")))) ;单选符合过滤表条件的实体
(progn
(initget "A")
(setq d (getdist (cadr e) "\nOffeset Dist [A - all]: "))
(if (= d "A")
(setq d (getdist (cadr e) "\nOffeset Dist: ")
tf t
)
d
)
)
)
(setq pts (xdrx_entity_getstretchpoint (car e)) ;获取实体的stretch点点表（WCS）
area (apply 'xdrx_points_area pts) ;获得点表组成的多边形的面积
tf1 (xdrx_curve_isclosed (car e)) ;判断两曲线是否共面
)
(if (minusp area)
(progn (xdrx_curve_reverse (car e)) ;判断两曲线是否共面
(if tf1
(xdrx_curve_setclosed (car e)) ;封闭曲线
)
)
)
(if tf
(progn
(setq npts (xdrx_curve_offset (car e) (- d))) ;OFFSET给定距离后的，曲线点表
(mapcar '(lambda (x y / ln) (make-extline (list x y))) npts (cdr npts))
)
(progn
(setq npts
(xdrx_polyline_getlinesegat ;获得一个直线段顶点的直线段数据 (起点终点)
(car e)
(fix (vlax-curve-getParamAtPoint (car e) (vlax-curve-getClosestPointTo (car e) (cadr e))))
)
an (+ (* pi 0.5) (apply 'angle npts))
npts (mapcar '(lambda (x) (polar x an d)) npts)
;;(apply 'xdrx_points_offset (cons (- d) npts));_ Bug
)
(make-extline npts)
)
)
)
(princ)
)

(defun c:tt (/ make-extline area d e npts pts tf tf1 an) 
  (defun make-extline (pts / ln ptl) 
    (setq ln  (apply 'xdrx_line_make pts) ;创建LINE实体 
          ptl (xdrx_curve_getinters (ssname ln 0) (car e) 1) ;两个AcDbCurve(曲线)实体的交点 
    ) 
    (xdrx_setpropertyvalue  ;设置对象的属性值 
      (ssname ln 0) 
      "startpoint" 
      (car ptl) 
      "endpoint" 
      (cadr ptl) 
    ) 
  ) 
  (while 
    (and (setq e (xdrx_entsel "\nPick Pline: " '((0 . "*polyline")))) ;单选符合过滤表条件的实体 
      (progn 
        (initget "A") 
        (setq d (getdist (cadr e) "\nOffeset Dist [A - all]: ")) 
        (if (= d "A") 
          (setq d  (getdist (cadr e) "\nOffeset Dist: ") 
                tf t 
          ) 
          d 
        ) 
      ) 
    ) 
    (setq pts (xdrx_entity_getstretchpoint (car e)) ;获取实体的stretch点  点表（WCS） 
          area (apply 'xdrx_points_area pts) ;获得点表组成的多边形的面积 
          tf1 (xdrx_curve_isclosed (car e))  ;判断两曲线是否共面 
    ) 
    (if (minusp area) 
      (progn (xdrx_curve_reverse (car e)) ;判断两曲线是否共面 
        (if tf1 
          (xdrx_curve_setclosed (car e)) ;封闭曲线 
        ) 
      ) 
    ) 
    (if tf 
      (progn 
        (setq npts (xdrx_curve_offset (car e) (- d)))  ;OFFSET给定距离后的，曲线点表 
        (mapcar '(lambda (x y / ln) (make-extline (list x y))) npts (cdr npts)) 
      ) 
      (progn 
        (setq npts 
          (xdrx_polyline_getlinesegat  ;获得一个直线段顶点的直线段数据 (起点 终点) 
            (car e) 
            (fix (vlax-curve-getParamAtPoint (car e) (vlax-curve-getClosestPointTo (car e) (cadr e)))) 
          ) 
          an   (+ (* pi 0.5) (apply 'angle npts)) 
          npts (mapcar '(lambda (x) (polar x an d)) npts) 
          ;;(apply 'xdrx_points_offset (cons (- d) npts));_ Bug 
        ) 
        (make-extline npts) 
       ) 
     ) 
  ) 
  (princ) 
)

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

[讨论] 如何实现选取边界自动偏移并插入块

本帖子中包含更多资源

相关帖子