点击生成垂直相交线

flytoday · 发表于 2011-12-15 11:53

生成十字相交线
条件:
1--四边方向均有线的不管封闭的还是未封闭的..
2--只要在四边方向都有线的,内侧任意点击就生成,两条垂直相交的线
3--垂直相交的线,取任意一边线中点与对应的另一边线垂直就好
4--十字相交的线和绝对是90度的
5--只要处理形似矩形的就好
6--一个一个就击生成
7--生成的相交线是新建一个层的
附图如下

测试文件

Gu_xl · 发表于 2011-12-15 11:53

本帖最后由 Gu_xl 于 2011-12-15 16:44 编辑

给你来个动态的

;;;右键结束命令
(defun c:tt(/ GR PT VS P1 P2 P3 P4 LINE1 LINE2 flag)
(while (not flag)
;(/= (car (setq gr (grread t 5 2))) 3)
(setq gr (grread t 7 2))
(cond ((= 5 (car gr))
(setq pt (cadr gr))
(setq vs (gxl-Sys-GetViewSize))
(if line1 (entdel line1))
(if line2 (entdel line2))
(setq line1 nil line2 nil)
(if (and
(setq p1 (getNearPoint pt (list (caadr vs) (cadr pt) (caddr pt)))) ;_ 向右
(setq p2 (getNearPoint pt (list (caar vs) (cadr pt) (caddr pt)))) ;_ 向左
(setq p3 (getNearPoint pt (list (car pt) (cadadr vs) (caddr pt)))) ;_ 向上
(setq p4 (getNearPoint pt (list (car pt) (cadar vs) (caddr pt)))) ;_ 向下
)
(progn
(setq line1 (makeline p1 p2))
(setq line2 (makeline p3 p4))
)
)
)
((= 25 (car gr))
(setq flag t)
(if line1 (entdel line1))
(if line2 (entdel line2))
(setq line1 nil line2 nil)
)
((= 3 (car gr))
(setq line1 nil line2 nil)
)
)
)
)
;;;用到的函数
;(gxl-Sys-GetViewSize)
(defun gxl-Sys-GetViewSize (/ pc vh sc vw vh pmin pmax)
(setq pc (getvar "viewctr")
vh (getvar "viewsize")
sc (getvar "screensize")
vw (* vh (/ (car sc) (cadr sc)))
pmin (list (- (car pc) (* 0.5 vw)) (- (cadr pc) (* 0.5 vh)))
pmax (list (+ (car pc) (* 0.5 vw)) (+ (cadr pc) (* 0.5 vh)))
)
(list pmin pmax)
)
(defun makeline (p1 p2)
(entmake (list (cons 0 "line")
(cons 8 "十字交叉") ;_ 图层
(cons 62 1) ;_ 颜色
(cons 10 (trans p1 1 0))
(cons 11 (trans p2 1 0))
)
)
(entlast)
)
;;;(gxl-SortPointOnCurve points curve) 参数点集 points 曲线图元 curve 点集沿曲线排序
(defun gxl-SortPointOnCurve (points curve / pl1 xx nn)
(setq pl1 (mapcar '(lambda (xx /)
(vlax-curve-getparamatpoint
curve
(vlax-curve-getclosestpointto curve xx)
)
)
points
)
)
(mapcar '(lambda (nn) (nth nn points))
(vl-sort-i pl1 '<)
)
)
(defun gxl-lst-split (lst len / tmp)
(if lst
(cons
(reverse
(repeat len
(if (car lst)
(setq tmp (cons (car lst) tmp)
lst (cdr lst)
)
)
tmp ;_ 制造返回值
)
)
(gxl-lst-split lst len)
)
)
)
(defun gxl-GetInterPointlist (obj1 obj2 )
(if (= 'ENAME (type obj1))
(setq obj1 (vlax-ename->vla-object obj1))
(if (= 'STR (type obj1))
(setq obj1 (vlax-ename->vla-object (handent obj1)))
)
)
(if (= 'ENAME (type obj2))
(setq obj2 (vlax-ename->vla-object obj2))
(if (= 'STR (type obj2))
(setq obj2 (vlax-ename->vla-object (handent obj2)))
)
)
(gxl-SortPointOnCurve (gxl-lst-split (vlax-invoke obj2 'IntersectWith obj1 acExtendNone) 3) obj2)
)
;;;计算与p1最近交点,没有返回nil
(defun getNearPoint (P1 P2 / SS LINE N EN PTS PT dxf)
(setq ss (ssget "f" (list p1 p2)))
(if ss
(progn
(setq line (makeline p1 p2))
(repeat (setq n (sslength ss))
(setq en (ssname ss (setq n (1- n))))
(if (or
(wcmatch (setq dxf (cdr (assoc 0 (entget en)))) "*LINE")
(= dxf "ARC")
(= dxf "CIRCLE")
(= dxf "ELLIPSE")
)
(setq pts (append pts (gxl-GetInterPointlist line en)))
)
)
(if pts
(setq pt (trans (car (gxl-SortPointOnCurve pts line)) 0 1))
)
(entdel line)
)
)
pt
)

;;;右键结束命令 
(defun c:tt(/ GR PT VS P1 P2 P3 P4 LINE1 LINE2 flag) 
  (while (not flag) 
    ;(/= (car (setq gr (grread t 5 2))) 3) 
    (setq gr (grread t 7 2)) 
    (cond ((= 5 (car gr)) 
    (setq pt (cadr gr)) 
    (setq vs (gxl-Sys-GetViewSize)) 
            (if line1 (entdel line1)) 
        (if line2 (entdel line2)) 
        (setq line1 nil line2 nil) 
    (if (and 
          (setq p1 (getNearPoint pt (list (caadr vs) (cadr pt) (caddr pt)))) ;_ 向右 
          (setq p2 (getNearPoint pt (list (caar vs) (cadr pt) (caddr pt)))) ;_ 向左 
          (setq p3 (getNearPoint pt (list (car pt) (cadadr vs) (caddr pt)))) ;_ 向上 
          (setq p4 (getNearPoint pt (list (car pt) (cadar vs) (caddr pt)))) ;_ 向下 
          
          ) 
      (progn 
        (setq line1 (makeline p1 p2)) 
        (setq line2 (makeline p3 p4)) 
        ) 
      ) 
              ) 
          ((= 25 (car gr)) 
           (setq flag t) 
           (if line1 (entdel line1)) 
        (if line2 (entdel line2)) 
        (setq line1 nil line2 nil) 
           ) 
          ((= 3 (car gr)) 
           (setq line1 nil line2 nil) 
           ) 
          ) 
    ) 
  ) 
;;;用到的函数 
;(gxl-Sys-GetViewSize) 
(defun gxl-Sys-GetViewSize (/ pc vh sc vw vh pmin pmax) 
  (setq pc (getvar "viewctr") 
                 vh (getvar "viewsize") 
                 sc (getvar "screensize") 
                vw (* vh (/ (car sc) (cadr sc))) 
                pmin (list (- (car pc) (* 0.5 vw)) (- (cadr pc) (* 0.5 vh))) 
                pmax (list (+ (car pc) (* 0.5 vw)) (+ (cadr pc) (* 0.5 vh))) 
           ) 
  (list pmin pmax) 
  ) 
(defun makeline (p1 p2) 
  (entmake (list (cons 0 "line") 
   (cons 8 "十字交叉") ;_ 图层 
   (cons 62 1) ;_ 颜色 
   (cons 10 (trans p1 1 0)) 
   (cons 11 (trans p2 1 0)) 
   ) 
    ) 
  (entlast) 
  ) 
;;;(gxl-SortPointOnCurve  points curve) 参数 点集 points 曲线图元 curve 点集沿曲线排序 
(defun gxl-SortPointOnCurve (points curve / pl1 xx nn) 
  (setq pl1 (mapcar '(lambda (xx /) 
         (vlax-curve-getparamatpoint 
    curve 
    (vlax-curve-getclosestpointto curve xx) 
         ) 
       ) 
      points 
     ) 
  ) 
  (mapcar '(lambda (nn) (nth nn points)) 
            (vl-sort-i pl1 '<)    
  ) 
) 
(defun gxl-lst-split (lst len / tmp) 
  (if lst 
    (cons 
      (reverse 
(repeat len 
   (if (car lst) 
     (setq tmp (cons (car lst) tmp) 
    lst (cdr lst) 
     ) 
   ) 
   tmp ;_ 制造返回值 
) 
      ) 
      (gxl-lst-split lst len) 
    ) 
  ) 
) 
(defun gxl-GetInterPointlist (obj1 obj2 ) 
  (if (= 'ENAME (type obj1)) 
    (setq obj1 (vlax-ename->vla-object obj1)) 
    (if (= 'STR (type obj1)) 
      (setq obj1 (vlax-ename->vla-object (handent obj1))) 
    ) 
  ) 
  (if (= 'ENAME (type obj2)) 
    (setq obj2 (vlax-ename->vla-object obj2)) 
    (if (= 'STR (type obj2)) 
      (setq obj2 (vlax-ename->vla-object (handent obj2))) 
    ) 
  ) 
  (gxl-SortPointOnCurve (gxl-lst-split (vlax-invoke obj2 'IntersectWith obj1 acExtendNone) 3) obj2) 
  ) 
;;;计算与p1最近交点,没有返回nil 
(defun getNearPoint (P1 P2 / SS LINE N EN PTS PT dxf) 
  (setq ss (ssget "f" (list p1 p2))) 
  (if ss 
    (progn 
      (setq line (makeline p1 p2)) 
      (repeat (setq n (sslength ss)) 
(setq en (ssname ss (setq n (1- n)))) 
(if (or 
       (wcmatch (setq dxf (cdr (assoc 0 (entget en)))) "*LINE") 
       (= dxf "ARC") 
       (= dxf "CIRCLE") 
       (= dxf "ELLIPSE") 
       ) 
    
(setq pts (append pts (gxl-GetInterPointlist line en))) 
   ) 
) 
      (if pts 
      (setq pt (trans (car (gxl-SortPointOnCurve pts line)) 0 1)) 
) 
      (entdel line) 
      ) 
    ) 
  pt 
  )

yjr111 · 发表于 2011-12-15 12:14

去下载我的角平分线吧

Andyhon · 发表于 2011-12-15 12:47

示例中的十字线有对中与不对中的差异
取决于什么条件?

flytoday · 发表于 2011-12-15 14:31

Andyhon 发表于 2011-12-15 12:47
示例中的十字线有对中与不对中的差异
取决于什么条件?

这个没有。。只要是十字线一边是从中点开始的。对应下来是垂直就好

highflybir · 发表于 2011-12-15 15:06

呵呵，羡慕有钱人哦。
Qjchen的有个程序可能适合你这样的情况。

flytoday · 发表于 2011-12-15 15:24

我要适用的适合的我弄不了啊

Andyhon · 发表于 2011-12-15 15:51

;;; 未经严谨测试

(Defun C:Test ()
(setq oldLs (getvar 'LtScale))
(setvar 'OsMode 0)

(setq xx (list 1 0 0)
      yy (list 0 1 0)
)

(command "LtScale" 1)
(While (Setq Pt (getpoint "\n内侧任意点击就生成,两条垂直相交的线: "))
   (setq p2 (mapcar '+ pt xx))
   (entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 p2)))
   (setq ee (entlast))
   (command "Extend" "All" "" pt p2 "")
   (setq pts (acet-geom-object-end-points ee)
         p5 (apply 'acet-geom-midpoint pts)
         pa (car pts)
   )

   (entdel ee)
   (setq Pt5 (apply 'acet-geom-midpoint (acet-geom-object-end-points (ssname (ssget pa '((0 . "LINE"))) 0)))
         p2 (mapcar '+ p5 yy)
   )

   (entmake (list '(0 . "LINE") (cons 10 p5) (cons 11 p2)))
   (command "Extend" "All" "" p5 p2 "")
   (entdel ee)
   (command "move" ee "" pa pt5)
)
(setvar 'LtScale oldLs)
)

flytoday · 发表于 2011-12-15 16:36

Gu_xl 谢谢您

很强大。佩服

太开心了

flytoday · 发表于 2011-12-15 16:36

向Gu_xl 哥至敬

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

点击生成垂直相交线

最佳答案

点评

本帖子中包含更多资源

评分

点评

点评