【Gu_xl】基于方位角计算的拓扑多边形自动构建快速算法

tm20038175

建议大家研究下这个帖子，在划分单元时候很实用，也十分感谢miraclelll的完善和优化…

漫长的等待

先收下了，谢谢！

tm20038175

呵呵，的确是好程序。

tm20038175

miraclelll 发表于 2012-9-20 10:29
哦,对不起, 忘记附上去了.... 以下是我优化后的 删除外包多边形

原来的思路是: 将每一个多边形和其他 ...

还是缺很多函数，例如：
1.SETUNDOERR
2.GXL-STR-SPACE
哎，等了一年还是没有解决~~~~~

123523058

希望看到完整的源码 谢谢大师

阿然

这么好的东西，先马克下，等发帖数够了慢慢研究！

阿然

古大，你这个程序为什么不支持pline呢？

mp13119

虽然看不懂！但觉得楼主很厉害！不知道楼主的程序能实现这样的功能吗？

Gu_xl

mp13119 发表于 2012-12-10 16:49
虽然看不懂！但觉得楼主很厉害！不知道楼主的程序能实现这样的功能吗？

这个动态定义填充图案填充即可！

1. (defun c:tt (/      X      Y      _A      PATNAME INDEX   PATH
   
2.       DIMZIN      OX      OY      F      FILENAME
   
3.       STR     cmdecho *error*
   
4.      )
   
5.   (defun *error* (s)
   
6.     (setvar 'dimzin dimzin)
   
7.     (setvar 'cmdecho cmdecho)
   
8.     (pronc s)
   
9.   )
   
10.   (setq x (getreal "\nX间距:<10.0>"))
    
11.   (if (null x)
    
12.     (setq x 10)
    
13.   )
    
14.   (setq y (getreal "\nY间距:<10.0>"))
    
15.   (if (null y)
    
16.     (setq y 10)
    
17.   )
    
18.   (setq _a (getangle "\n旋转角度<0>:"))
    
19.   (if (null _a)
    
20.     (setq _a "0")
    
21.     (setq _a (angtos _a))
    
22.   )
    
23.   (setq patname "TEMPPA_"
    
24. index 0
    
25.   )
    
26.   (while
    
27.     (ssget "x"
    
28.     (list '(0 . "hatch") (cons 2 (strcat patname (itoa index))))
    
29.     )
    
30.      (setq index (1+ index))
    
31.   )
    
32.   (setq patname (strcat patname (itoa index)))
    
33.   (setq path (GETVAR (QUOTE ROAMABLEROOTPREFIX))
    
34. dimzin (getvar (quote dimzin))
    
35. cmdecho (getvar 'cmdecho)
    
36.   )
    
37.   (setvar 'dimzin 8)
    
38.   (setvar 'cmdecho 0)
    
39.   (or (eq "\\" (substr path (strlen path)))
    
40.       (setq path (strcat path "\\"))
    
41.   )
    
42.   (setq path (strcat path "Support\\"))
    
43.   (setq f (open (setq filename (strcat path patname ".pat")) "w"))
    
44.   (write-line
    
45.     (setq str (strcat "*" patname ",临时填充图案 " patname))
    
46.     f
    
47.   )
    
48.   (write-line (strcat "0,0,0,0," (rtos x 2 10)) f)
    
49.   (write-line (strcat "90,0,0,0," (rtos y 2 10)) f)
    
50.   (close f)
    
51.   (setq endent (entlast))
    
52.   (if (>= (atoi (getvar 'acadver)) 17)
    
53.     (progn
    
54.       (command "_Bhatch" "p" patname "1" _a "o" "d" "l" "n")
    
55.       (princ "\n**选择区域点**")
    
56.       (while (= 1 (getvar 'cmdactive))
    
57. (command pause)
    
58.       )
    
59.     )
    
60.     (progn
    
61.       (command "_Bhatch" "p" patname "1" _a)
    
62.       (princ "\n**选择区域点**")
    
63.       (while (= 1 (getvar 'cmdactive))
    
64. (command pause)
    
65.       )
    
66.     )
    
67.   )
    
68.   (setq hatch (entlast))
    
69.   (if (not (equal endent hatch))
    
70.     (command "_explode" hatch)
    
71.   )
    
72.   (vl-file-delete filename)
    
73.   (setvar 'dimzin dimzin)
    
74.   (setvar 'cmdecho cmdecho)
    
75.   (princ)
    
76. )

(defun c:tt (/      X      Y      _A      PATNAME INDEX   PATH<br />       DIMZIN      OX      OY      F      FILENAME<br />       STR     cmdecho *error*<br />      )<br />   (defun *error* (s)<br />     (setvar 'dimzin dimzin)<br />     (setvar 'cmdecho cmdecho)<br />     (pronc s)<br />   )<br />   (setq x (getreal "\nX间距:<10.0>"))<br />   (if (null x)<br />     (setq x 10)<br />   )<br />   (setq y (getreal "\nY间距:<10.0>"))<br />   (if (null y)<br />     (setq y 10)<br />   )<br />   (setq _a (getangle "\n旋转角度<0>:"))<br />   (if (null _a)<br />     (setq _a "0")<br />     (setq _a (angtos _a))<br />   )<br />   (setq patname "TEMPPA_"<br /> index 0<br />   )<br />   (while<br />     (ssget "x"<br />     (list '(0 . "hatch") (cons 2 (strcat patname (itoa index))))<br />     )<br />      (setq index (1+ index))<br />   )<br />   (setq patname (strcat patname (itoa index)))<br />   (setq path (GETVAR (QUOTE ROAMABLEROOTPREFIX))<br /> dimzin (getvar (quote dimzin))<br /> cmdecho (getvar 'cmdecho)<br />   )<br />   (setvar 'dimzin 8)<br />   (setvar 'cmdecho 0)<br />   (or (eq "\\" (substr path (strlen path)))<br />       (setq path (strcat path "\\"))<br />   )<br />   (setq path (strcat path "Support\\"))<br />   (setq f (open (setq filename (strcat path patname ".pat")) "w"))<br />   (write-line<br />     (setq str (strcat "*" patname ",临时填充图案 " patname))<br />     f<br />   )<br />   (write-line (strcat "0,0,0,0," (rtos x 2 10)) f)<br />   (write-line (strcat "90,0,0,0," (rtos y 2 10)) f)<br />   (close f)<br />   (setq endent (entlast))<br />   (if (>= (atoi (getvar 'acadver)) 17)<br />     (progn<br />       (command "_Bhatch" "p" patname "1" _a "o" "d" "l" "n")<br />       (princ "\n**选择区域点**")<br />       (while (= 1 (getvar 'cmdactive))<br /> (command pause)<br />       )<br />     )<br />     (progn<br />       (command "_Bhatch" "p" patname "1" _a)<br />       (princ "\n**选择区域点**")<br />       (while (= 1 (getvar 'cmdactive))<br /> (command pause)<br />       )<br />     )<br />   )<br />   (setq hatch (entlast))<br />   (if (not (equal endent hatch))<br />     (command "_explode" hatch)<br />   )<br />   (vl-file-delete filename)<br />   (setvar 'dimzin dimzin)<br />   (setvar 'cmdecho cmdecho)<br />   (princ)<br /> )

soly2006

\能否对多段线进行拓扑计算？
正想用到检查小构面的内容。