直线偏移联动

masterlong

;|
类似于edata发布的程序“直线偏移连动~偏移后修改与其相接触的直线”
和他不同的是
edata的程序需要先指定偏移距离，再选择直线，最后指定偏移方向
而我的程序是
先选择参照直线，再选择偏移目标点，直接计算出偏移距离
如果两头都有【同层】线相连，那么参照直线执行偏移
如果仅一头有线相连，那么偏移同时，改变直线到偏移目标点
由于我的应用环境，需要进行如上操作的都是互相垂直的线，所以没加入斜角相交延伸的功能
|;

(vl-load-com)


;;命令是OLL        ————话说，论坛能设置成屏蔽“字母组合自动转表情”吗？？？？
(defun c:oll()
(if (setq ss (ssget":E:S" '((0 . "line"))))
  (progn
   (command "undo" "g")
   (ssdraw ss 3)
   (setq pickpt (last (last (car (ssnamex ss)))))  ;;选取点
   (setq line (ssname ss 0))
   (setq lay (dxf 8 line))
   (setq p10 (dxf 10 line))
   (setq p11 (dxf 11 line))
   (if (< (distance p10 pickpt) (distance p11 pickpt))
    (setq pa p10  pb p11)
    (setq pa p11  pb p10)
   )
   (zooment line 2)
   (setq ss1 (ssget "F" (list p10 p11) (list '(0 . "line") (cons 8 lay))))
   (setq ss1 (ss2list ss1))
   (setq ss1 (vl-remove line ss1))
       (command "_.zoom" "p")
       (ssdraw ss1 3)
      
       (if (setq pc (getpoint pa "\n指定偏移点: "))
        (progn
         (setq yn (vl-remove-if-not ''((one) (or (equal (distance (dxf 10 one) pa) 0 5) (equal (distance (dxf 11 one) pa) 0 5))) ss1))
         (do_offset)
        )
       )
       (ssdraw ss  4)
       (ssdraw ss1 4)
       (command "undo" "e")
       (c:oll)
  )
)
(princ)
)
(defun do_offset()
(setq ang (angle pa pc))
(setq dist (distance pa pc))
(setq pd (polar pb ang dist))
(setq pd (per_po pb pc pd))
(if yn
  (setq pc (per_po pa pc pd))
)
(entmodone line 10 pc)
(entmodone line 11 pd)
;|
(setq pa (list (car pa) (cadr pa)))
(setq pb (list (car pb) (cadr pb)))
(setq pc (list (car pc) (cadr pc)))
(setq pd (list (car pd) (cadr pd)))
|;
(foreach linef ss1
  (setq pm (dxf 10 linef)
    pn (dxf 11 linef)
  )
  ;;(setq pm (list (car pm) (cadr pm)))
  ;;(setq pn (list (car pn) (cadr pn)))
  (setq px (inters pa pb pm pn NIL))
  (cond
   ((equal (distance pm px) 0 5)  (setq dxfnm 10))
   ((equal (distance pn px) 0 5)  (setq dxfnm 11))
   ( T (setq dxfnm NIL))
  )
  (setq px (inters pc pd pm pn NIL))
  (if (and px dxfnm)
   (entmodone linef dxfnm px)
  )
)
)

;;公共函数
;999获取图元某个dxf组码
(defun dxf( ent n / temp )
(if (and (= (type ent) 'int) (= (type n) 'ename))
  (setq temp  ent
    ent n
    n  temp
  )
)
(cdr (assoc n (entget ent)))
)

;999按指定的模式重画一个选择集的全部物体<改模式时，需要先反绘。1-2 3-4.(1->4=1->2->4)>    【支持模型多视口，支持布局中视口】
;;  1:显示  2:消隐  3:高亮  4:低亮
(defun ssdraw( ss mode / i ent )
(if (= (strcase (getvar "ctab")) "MODEL")
  (if (member mode '(1 2 3 4))
   (foreach vp (reverse (vports))
    (setvar "cvport" (car vp))
    (cond
     ((= (type ss) 'PICKSET)
      (foreach ent (ss2list ss)
       (redraw ent mode)
      )
     )
     ((= (type ss) 'list)
      (foreach ent ss
       (redraw ent mode)
      )
     )
     ((= (type ss) 'ename)
      (redraw ss mode)
     )
    )
   )
  )
  (cond
   ((= (type ss) 'PICKSET)
    (foreach ent (ss2list ss)
     (redraw ent mode)
    )
   )
   ((= (type ss) 'list)
    (foreach ent ss
     (redraw ent mode)
    )
   )
   ((= (type ss) 'ename)
    (redraw ss mode)
   )
  )
)
(princ)
)

;999以指定图元缩放窗口
(defun zooment( ent sc / box x midpo )
(setq *acad*      (vlax-get-acad-object))
(setq box (entbox ent))
(setq midpo (getmidpo box))
(setq box (mapcar '(lambda (x) (p0_sc_p1 midpo x sc)) box))
(vla-zoomwindow *acad* (vlax-3d-point (car box)) (vlax-3d-point (cadr box)))
box
)

;999以基点p0缩放p1————P0为缩放基点
(defun p0_sc_p1 (p0 p1 sc )
  (polar p0 (angle p0 p1) (* sc (distance p0 p1)))
)

;999修改一个图元的某个数据   ——————不是所有的图元都适用此方式
(defun entmodone( ent dxfnum data )
(entmod (list (cons -1 ent)(cons dxfnum data)))
)
;999一点到另两点形成直线的垂足
(defun per_po( p1 p2 p3 / ang ptemp )
(setq ang (angle p2 p3))
(setq ang (+ ang (/ PI 2)))
(setq ptemp (polar p1 ang 1000))
(inters p1 ptemp p2 p3 nil)
)


漏了一些子函数见7楼

yoyoho

谢谢! masterlong 分享程序!!!!!

bai2000

建议发压缩文件包

masterlong

知道edata说的方法
但是论坛以前还好
点“复制代码”
整个代码就复制下来了
粘贴也很正常
现在操作就全部变成了一行
所以就很不喜欢用这个功能了

不过后来发现
可以先点“普通浏览”
在弹出窗口里全选复制

ssyfeng

少了一些函数

yoyoho

ssyfeng 发表于 2018-11-4 14:19
少了一些函数

;;;选集转图元名表
;;;(ss2list (SSGET))
;;;(<图元名称: 7ef14230> <图元名称: 7ef14228> <图元名称: 7ef14220>)
(defun ss2list ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (ssname ss (setq i (1- i))) l))
        )
    )
)

;;By Longxin 明经通道 2005.06
;;取得实体外矩形框
;;例：(entbox 图元名)
;;返回：((x1 y1 z1)_min (x2 y2 z2)_max)
;;(entbox (CAR(ENTSEL)))
(defun entbox (e1 / obj minpoint maxpoint)
  (setq obj (vlax-ename->vla-object e1)) ;转换图元名
  (vla-GetBoundingBox obj 'minpoint 'maxpoint)
                    ;取得包容图元的最大点和最小点
  (setq minpoint (vlax-safearray->list minpoint)) ;把变体数据转化为表
  (setq maxpoint (vlax-safearray->list maxpoint)) ;把变体数据转化为表
  ;;(command "box" minpoint maxpoint 2)
  (setq obj (list minpoint maxpoint))
)

;;; ----------------------- getmidpo --------------------------
;;; 两点之中点
;;;方式 : (setq pt3 (getmidpo LST))
;;;LST为表,且为两个点的点表,如(528762.0 6045.65 0.0) (530541.0 8015.43 0.0))
(defun getmidpo (LST)
(list (/ (+ (CAR (NTH 0 LST)) (CAR (NTH 1 LST))) 2)
(/ (+ (cadr (NTH 0 LST)) (cadr (NTH 1 LST))) 2)
(/ (+ (caddr (NTH 0 LST)) (caddr (NTH 1 LST))) 2)
)
)

masterlong

谢谢yoyoho
贴上我的子函数


;999公共函数
;;选择集转为图元列表
(defun ss2list ( ss / n i elist )
(cond
  ((= (type ss) 'Pickset)
   (setq n  (sslength ss)
     i n
     elist '()
   )
   (repeat n
    (setq i (1- i))
    ;;如果没有这个if，那么选择集中被删除的图元，也会被加入到列表之中————但是极其偶尔也有可能，图元不存在但是能entget（遇到过一次，原因不明，或许是CAD的BUG）
    (if (entget (ssname ss i))
     (setq elist (cons (ssname ss i) elist))
    )
   )
   elist
  )
  ((= (type ss) 'ename)
   (list ss)
  )
  ((= (type ss) 'list)
   (vl-remove-if-not ''((x) (and (= (type x) 'ename) (entget x))) ss)
  )
  ( T NIL)
)
)



;999单个物体的最小（正交）包围框---------------------------------这个程序在遇到无法显示的图元时，还是会出错的，比如形。天正图元会不会也不支持，未测试
(defun entbox ( ent / ll ur )
(vla-getboundingbox (vlax-Ename->Vla-Object ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)




;999公共函数
;;求点对中点
(defun getmidpo( pts / P1 P2 X Y )
(setq p1 (car pts) p2 (cadr pts))
(if (= (length p1) (length p2))
  nil
  (setq p1 (list (car p1) (cadr p1))
    p2 (list (car p2) (cadr p2))
  )
)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)

yoyoho

谢谢! masterlong 分享子函数!!!!

edata

masterlong 发表于 2018-11-4 13:31
知道edata说的方法
但是论坛以前还好
点“复制代码”

在代码区的第一个字符点一下，按shift点代码区最后一个字符，就能选择该区域的文字，复制粘贴就带lisp格式了。或者手动拖动选择也可以。。