简单操作不堪重负，深夜求急诊！！--平行图块自动连线

半听可乐

longcashman 发表于 2014-6-5 23:37
来看看我榨出来的脑汁
老顾的排序太高大上了，看不懂。
突然想到直接画构造线然后打断的法子，

朋友，为了帮这个忙，花了那么多功夫，真是过意不去，在此对你的辛勤付出感激不尽！但是经过使用，发现连的线是一段一段的，还有就是并没有完全连上（都是一条线上的，只连了一部分），G版和院长的感觉是要快些，能否将他们的完善一下？不懂lisp ，实在是惭愧~~

longcashman

我理解错了，我是特意断成1段1段的，慢就慢在这了。
我开始画构造线的版本应该可以用
我找找再发出来
版主那个需要坐标转换的目前我的能力达不到
院长那个闭源苹果公司的范儿也学不来

longcashman

1. (defun GetMinExtents (plist /)
   
2.   (list
   
3.     (apply 'mapcar (cons 'min plist))
   
4.     (apply 'mapcar (cons 'min plist))
   
5.   )
   
6. )
   
7. (defun GetMaxExtents (plist /)
   
8.   (list
   
9.     (apply 'mapcar (cons 'max plist))
   
10.     (apply 'mapcar (cons 'max plist))
    
11.   )
    
12. )
    
13. ;;;判断平面上的三点是否共线By highflybir               ;
    
14. ;;;----------------------------------------------------;
    
15. ;;;功能: 判断平面上的三点是否共线                      ;
    
16. ;;;输入: 三点 P1,P2,P3                                 ;
    
17. ;;;输出: T 说明三点共线，否则不共线                    ;
    
18. ;;;----------------------------------------------------;
    
19. (defun ptAtLine?  (p1 p2 p3 / a b c eps)
    
20.   (setq eps 1e-6)
    
21.   (setq a (distance p2 p3))
    
22.   (setq b (distance p3 p1))
    
23.   (setq c (distance p1 p2))
    
24.   (or (equal (+ a b) c eps)
    
25.       (equal (+ b c) a eps)
    
26.       (equal (+ c a) b eps)
    
27.       )
    
28.   )
    
29. ;;; 旋转一个向量或者点90度By highflybird               ;
    
30. (defun MAT:Rot90  (vec)
    
31.   (vl-list* (- (cadr vec)) (car vec) (cddr vec))
    
32.   )
    
33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
35. ;;[功能] 选择集->图元列表 By caiqs          ;
    
36. (defun ss->lst        (ss / retu)
    
37.   (setq retu (apply 'append (ssnamex ss)))
    
38.   (setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu))
    
39.   )
    
40. 
    
41. ;;示例 (MJ:Massoc 10 (entget (car (entsel))))
    
42. ;; Notes:特别适合多段线各顶点;作者不详      
    
43. (defun MJ:Massoc  (key alist)
    
44.   (apply
    
45.     'append
    
46.     (mapcar '(lambda (x)
    
47.                (if (eq (car x) key)
    
48.                  (list (cdr x))
    
49.                  )
    
50.                )
    
51.             alist
    
52.             )
    
53.     )
    
54.   )
    
55. 
    
56. 
    
57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
58. 
    
59. (defun makeDirPts (ptlst dir / aline ent p1 p2 sumaline)
    
60. 
    
61.   (while ptlst
    
62.     (setq aline nil)
    
63.     (setq p1 (car ptlst))
    
64.     (setq p2 (mapcar '+ p1 dir))
    
65.     (setq aline (cons p1 aline))
    
66.     (setq ptlst (cdr ptlst))
    
67.     (foreach pt        ptlst
    
68.       (if (ptAtLine? pt p1 p2)
    
69.         (progn
    
70.           (setq aline (cons pt aline))
    
71.           (setq ptlst (vl-remove-if '(lambda (x) (equal pt x)) ptlst))
    
72.         )
    
73.       )
    
74.     )
    
75.     (setq sumaline (cons aline sumaline))
    
76.   )
    
77.   sumaline
    
78. )
    
79. 
    
80. (defun toDraw (psatline / ootst maxd distop1 index endptlst endpts)
    
81.   
    
82.   (foreach ps psatline
    
83.         (setq ootst
    
84.            (mapcar '(lambda (p)
    
85.                       (setq
    
86.                         distop1        (mapcar '(lambda (pt) (distance pt p)) ps)
    
87.                       )
    
88.                       (setq maxd (apply 'max distop1))
    
89.                       (cons maxd (vl-position maxd distop1))
    
90.                     )
    
91.                    ps
    
92.            )
    
93.     )
    
94.     (setq index (apply 'max (mapcar 'car ootst)))
    
95.     (setq endpts nil)
    
96.     (foreach item ootst
    
97.       (if (setq it (assoc index (list item)))
    
98.         (setq endpts (cons (nth (cdr it) ps) endpts))
    
99.       )
    
100.     )
     
101.     (setq endptlst (cons endpts endptlst))
     
102.   )
     
103.   (foreach item        endptlst
     
104.     (vl-cmdf "_.line" (car item) (cadr item) "")
     
105.   )
     
106. )
     
107. 
     
108. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
109. ;;;主函数;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
110. (defun assistLine  (/ dir1 dir2 ss enlst ptlst dirlinent)
     
111.   (if  blkName
     
112.     (setq blkName "j_pt1")
     
113.     (setq blkName (cdr (assoc 2 (entget (car (entsel "\n 选择样例喷头"))))))
     
114.             )
     
115.   (setvar "osmode" 4)
     
116.   (setq dirlinent (entget(car(entsel"\n 选择方向线"))))
     
117.   (setq        dir1 (mapcar '-
     
118.                      (cdr (assoc 10 dirlinent))
     
119.                      (cdr (assoc 11 dirlinent))
     
120.                      )
     
121.         )
     
122.   (setq dir2 (MAT:Rot90 dir1))
     
123.   (setvar "osmode" 0)
     
124.   (princ "\n 框选喷头范围")
     
125. 
     
126.   (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))
     
127.   (setq enlst (ss->lst ss))
     
128.   (setq
     
129.     ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en))))
     
130.                   enlst
     
131.                   )
     
132.     )                                
     
133. (toDraw (makeDirPts ptlst dir1))
     
134.   (toDraw (makeDirPts ptlst dir2))
     
135.   )
     
136. (defun c:bb  (/ oldOs oldClayer)
     
137.   (setq oldOs (getvar "osmode"))
     
138.   (setq oldClayer (getvar "clayer"))
     
139.   (setvar "clayer" "SZ_FINE")
     
140.   (assistLine)
     
141.   (setvar "osmode" oldOs)
     
142.   (setvar "clayer" oldClayer)
     
143.   (princ)
     
144.   )
     
145. 
     
146. 
     
147. 
     
148. 
     
149. 
     
150. 
     
151. 
     
152. 
     
153. 
     

(defun GetMinExtents (plist /)<br />   (list<br />     (apply 'mapcar (cons 'min plist))<br />     (apply 'mapcar (cons 'min plist))<br />   )<br /> )<br /> (defun GetMaxExtents (plist /)<br />   (list<br />     (apply 'mapcar (cons 'max plist))<br />     (apply 'mapcar (cons 'max plist))<br />   )<br /> )<br /> ;;;判断平面上的三点是否共线By highflybir               ;<br /> ;;;----------------------------------------------------;<br /> ;;;功能: 判断平面上的三点是否共线                      ;<br /> ;;;输入: 三点 P1,P2,P3                                 ;<br /> ;;;输出: T 说明三点共线，否则不共线                    ;<br /> ;;;----------------------------------------------------;<br /> (defun ptAtLine?  (p1 p2 p3 / a b c eps)<br />   (setq eps 1e-6)<br />   (setq a (distance p2 p3))<br />   (setq b (distance p3 p1))<br />   (setq c (distance p1 p2))<br />   (or (equal (+ a b) c eps)<br />       (equal (+ b c) a eps)<br />       (equal (+ c a) b eps)<br />       )<br />   )<br /> ;;; 旋转一个向量或者点90度By highflybird               ;<br /> (defun MAT:Rot90  (vec)<br />   (vl-list* (- (cadr vec)) (car vec) (cddr vec))<br />   )<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;[功能] 选择集->图元列表 By caiqs          ;<br /> (defun ss->lst        (ss / retu)<br />   (setq retu (apply 'append (ssnamex ss)))<br />   (setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu))<br />   )<br /> <br /> ;;示例 (MJ:Massoc 10 (entget (car (entsel))))<br /> ;; Notes:特别适合多段线各顶点;作者不详       <br /> (defun MJ:Massoc  (key alist)<br />   (apply<br />     'append<br />     (mapcar '(lambda (x)<br />                (if (eq (car x) key)<br />                  (list (cdr x))<br />                  )<br />                )<br />             alist<br />             )<br />     )<br />   )<br /> <br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> <br /> (defun makeDirPts (ptlst dir / aline ent p1 p2 sumaline)<br /> <br />   (while ptlst<br />     (setq aline nil)<br />     (setq p1 (car ptlst))<br />     (setq p2 (mapcar '+ p1 dir))<br />     (setq aline (cons p1 aline))<br />     (setq ptlst (cdr ptlst))<br />     (foreach pt        ptlst<br />       (if (ptAtLine? pt p1 p2)<br />         (progn<br />           (setq aline (cons pt aline))<br />           (setq ptlst (vl-remove-if '(lambda (x) (equal pt x)) ptlst))<br />         )<br />       )<br />     )<br />     (setq sumaline (cons aline sumaline))<br />   )<br />   sumaline<br /> )<br /> <br /> (defun toDraw (psatline / ootst maxd distop1 index endptlst endpts)<br />   <br />   (foreach ps psatline<br />         (setq ootst<br />            (mapcar '(lambda (p)<br />                       (setq<br />                         distop1        (mapcar '(lambda (pt) (distance pt p)) ps)<br />                       )<br />                       (setq maxd (apply 'max distop1))<br />                       (cons maxd (vl-position maxd distop1))<br />                     )<br />                    ps<br />            )<br />     )<br />     (setq index (apply 'max (mapcar 'car ootst)))<br />     (setq endpts nil)<br />     (foreach item ootst<br />       (if (setq it (assoc index (list item)))<br />         (setq endpts (cons (nth (cdr it) ps) endpts))<br />       )<br />     )<br />     (setq endptlst (cons endpts endptlst))<br />   )<br />   (foreach item        endptlst<br />     (vl-cmdf "_.line" (car item) (cadr item) "")<br />   )<br /> )<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;;主函数;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun assistLine  (/ dir1 dir2 ss enlst ptlst dirlinent)<br />   (if  blkName<br />     (setq blkName "j_pt1")<br />     (setq blkName (cdr (assoc 2 (entget (car (entsel "\n 选择样例喷头"))))))<br />             )<br />   (setvar "osmode" 4)<br />   (setq dirlinent (entget(car(entsel"\n 选择方向线"))))<br />   (setq        dir1 (mapcar '- <br />                      (cdr (assoc 10 dirlinent))<br />                      (cdr (assoc 11 dirlinent))<br />                      )<br />         )<br />   (setq dir2 (MAT:Rot90 dir1))<br />   (setvar "osmode" 0)<br />   (princ "\n 框选喷头范围")<br /> <br />   (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))<br />   (setq enlst (ss->lst ss))<br />   (setq<br />     ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en))))<br />                   enlst<br />                   )<br />     )                                <br /> (toDraw (makeDirPts ptlst dir1))<br />   (toDraw (makeDirPts ptlst dir2))<br />   )<br /> (defun c:bb  (/ oldOs oldClayer)<br />   (setq oldOs (getvar "osmode"))<br />   (setq oldClayer (getvar "clayer"))<br />   (setvar "clayer" "SZ_FINE")<br />   (assistLine)<br />   (setvar "osmode" oldOs)<br />   (setvar "clayer" oldClayer)<br />   (princ)<br />   )<br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br /> <br />

gzxl

其实大大们已经给出了源码了，我试着按院长和G版的提供的写了下
好像是这样
(defun c:tt ( / a ge i len lst1 lst2 pl pt s1 s2 s3 ss)
  (setq i -1)
  (if (setq ss (ssget '((0 . "insert") (2 . "j_pt1") (8 . "SZ-喷头设备"))))
    (progn
      (setq len (sslength ss) pl nil)
      (repeat len
         (setq ge (ssname ss (setq i (1+ i))))
         (setq pt (cdr (assoc 10 (entget ge))))
         (setq pl (cons pt pl))
      )
      (setq lst1 (sortPtsX pl 0.001)
            lst2 (sortPtsY pl 0.001)
      )
      (if (null (tblsearch "layer" "SZ_FINE")) (EntmakeLayer 1 "SZ_FINE"))
      (setvar "clayer" "SZ_FINE")
      (foreach a lst1
        (setq s1 (car a) s2 (last a))
        (EntmakeLine s1 s2)
      )
      (foreach a lst2
        (setq s1 (car a)
              s2 (last a)
        )
        (EntmakeLine s1 s2)
      )
      (setvar "clayer" "0")
    )
  )
  (princ)
)
(defun EntmakeLayer (c n)
  (entmake
    (list
      '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
      '(70 . 0) '(6 . "Continuous") (cons 62 c) (cons 2 n)
    )
  )
)
(defun sortPtsX (pts tol / LST L)
  (setq pts
    (vl-sort
      pts
     '(lambda (a b)
        (if (equal (cadr a) (cadr b) tol)
          (< (car a) (car b))   ;_ X方向从小到大排序
          (< (cadr a) (cadr b)) ;_ Y方向从小到大
        )
      )
    )
  )
  ;;对pts进行分组
  (setq  lst nil
         L   (list (car pts))
         pts (cdr pts)
  )
  (while pts
    (if (equal (cadar pts) (cadar L) tol)
      (setq L   (cons (car pts) L)
            pts (cdr pts)
      )
      (setq lst (cons L lst)
            L   (list (car pts))
            pts (cdr pts)
      )
    )
  )
  (setq lst (cons L lst))
)
(defun sortPtsY (pts tol / LST L)
  (setq pts
    (vl-sort
      pts
     '(lambda (a b)
        (if (equal (car a) (car b) tol)
          (< (cadr a) (cadr b))
          (> (car a) (car b))
        )
      )
    )
  )
  (setq  lst nil
         L   (list (car pts))
         pts (cdr pts)
  )
  (while pts
    (if (equal (caar pts) (caar L) tol)
      (setq L   (cons (car pts) L)
            pts (cdr pts)
      )
      (setq lst (cons L lst)
            L   (list (car pts))
            pts (cdr pts)
      )
    )
  )
  (setq lst (cons L lst))
)
(defun EntmakeLine (pt1 pt2)
  (entmake (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2)))
)

半听可乐

gzxl 发表于 2014-6-6 17:14
其实大大们已经给出了源码了，我试着按院长和G版的提供的写了下
好像是这样
(defun c:tt ( / a ge i len  ...

朋友，感谢你的帮助，但是这个生成的有重复线段

半听可乐

longcashman 发表于 2014-6-6 16:35

BB
选择样例喷头
选择方向线error: 参数类型错误: numberp: nil

朋友，感谢关注，还是有点小问题哦

longcashman

半听可乐 发表于 2014-6-6 20:22
BB
选择样例喷头
选择方向线error: 参数类型错误: numberp: nil

(defun assistLine  (/ dir1 dir2 ss enlst ptlst dirlinent)
   (if (not (setq en (car (entsel "\n 选择样例喷头"))))
    (setq blkName "j_pt1");
    (setq blkName (cdr (assoc 2 (entget en))))
  )
  (setvar "osmode" 4)
  (setq dirlinent (entget(car(entsel"\n 选择方向线"))))
  (setq        dir1 (mapcar '-
                     (cdr (assoc 10 dirlinent))
                     (cdr (assoc 11 dirlinent))
                     )
        )
  (setq dir2 (MAT:Rot90 dir1))
  (setvar "osmode" 0)
  (princ "\n 框选喷头范围")

  (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))
  (setq enlst (ss->lst ss))
  (setq
    ptlst (mapcar '(lambda (en) (car (MJ:Massoc 10 (entget en))))
                  enlst
                  )
    )                               
(toDraw (makeDirPts ptlst dir1))
  (toDraw (makeDirPts ptlst dir2))
  )

半听可乐

longcashman 发表于 2014-5-17 01:50
我刚看到你图纸上还有一个不输入方向的要求；替换下面的函数大概可以满足要求
其实是个偷懒的办法，高飞鸟 ...

非常感谢朋友的热心相助，现在的程序终于能完美满足我的要求了！在此一并感谢G版、院长、gzxl 的鼎立相助，感谢你们！

水牛

如果两个方向的线分图层就好了。有谁能改？

egoroom

看下。。学习中。。。。