恳请大师帮忙优化一下打印图框排序问题

669423907

恳请大师帮忙优化一下打印图框排序问题
源码是本论坛上的，在此谢过作者，也有大师帮改了一些，自己也改了一下打印选项，现在只差排序问题，排序有点乱。恳请大师们帮忙修改一下。
希望改为先从左到又，从上到下排序并按顺序打印，再此先谢过了
;框选矩型图框批量打印 langjs 2012-6-18 ;http://bbs.mjtd.com/thread-94175-1-1.html
(defun c:13(/ ent fx i maxpoint xx0 xy0 minpoint x0 y0 os pmax pmin ptlist dybj bj tcm ys)

  (vl-load-com)
  (setvar "cmdecho" 0)
(setq tzsl(ssadd) dybj(ssadd) )

;  (princ "\n请选取要打印的矩形图框:")
;  (setq tzsl (ssget (list '(0 . "LWPOLYLINE")'(8 . "图框") '(90 . 4))))

(setq
dayin '()
tzsl '()
dyfs '()
dyj '()
A? '()
dy '()
)

(setq dayin 1)  ;打印调用标记
(sexuan?)  ;按颜色选择对象

  (setq tzsl (ssget "p" '((0 . "LWPOLYLINE"))))

(if (/= tzsl nil)(progn

(setq tcm "3不打印")  ;图层名
(setq ys 200)         ;图层颜色
(if (not (tblsearch "layer" tcm)) (progn ;判断图层是否存在
(command (setq la (getvar"clayer")) "layer" "m" tcm "C" ys "" "" "N" "" "" "clayer" la)
) )  ;不存在则新建图层

  (setq n (sslength tzsl) i 0)
  (setq dybj (ssadd))  ;打印标记集
  (repeat n
    (setq ent (ssname tzsl i))
    (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
    (setq pmax (vlax-safearray->list maxpoint)  pmin (vlax-safearray->list minpoint)
x0(car pmin)
y0(cadr pmin)
xx0(car pmax)
xy0(cadr pmax)
)

(if (= L? nil)(setq L? "L"))  ;打印方向
(if (= P? nil)(setq P? ""))  ;打印方向
    (if (>= (- xx0 x0) (- xy0 y0)) (setq fx L?)(setq fx P?) )

    (grdraw (list x0 y0 0) (list xx0 xy0 0) 1 1)  ;临时标记线
    (grdraw (list x0 xy0 0) (list xx0 y0 0) 1 1)  ;临时标记线

(if(setq bj(ssget "c" (list x0 y0)(list xx0 xy0)(list '(0 . "*text")(cons 8 tcm)(cons 62 ys)))) (command"erase"bj"") )  ;删除打印标记文字
(if (> i 98) (setq zigao(*(- xy0 y0)0.66)) (setq zigao(- xy0 y0)) )  ;打印标记文字高度
(setvar 'osmode 0)  ;关闭捕捉
    (entmake (list '(0 . "text")(cons 1(itoa(1+ i)))(cons 10(list x0 y0 0))(cons 40 zigao)(cons 8 tcm)(cons 62 ys) ))  ;写打印标记
(setvar 'osmode 1)  ;打开捕捉
    (ssadd (entlast) dybj)  ;打印标记集
    (setq ptlist (cons (list pmin pmax fx) ptlist))
    (setq i (1+ i))
  )

(dyxx)  ;打印选项设置

(if (= dyj nil)(setq dyj (xtdyj)) )  ;默认为系统打印机
(if (= dyys nil)(setq dyys "monochrome.ctb"))  ;打印样式
(if (= A? nil)(setq A? "A4")) ;纸张选择
(if (= dyfs nil)(setq dyfs 1))  ;打印份数

(repeat dyfs

  (if (= dy 1)
    (progn
      (setq i 0)
      (repeat (length ptlist)
        (setq ent (nth i ptlist )  pmin (car ent) pmax (cadr ent) fx (last ent))
(setq i (1+ i))
(setq sysl (itoa(-(length ptlist)i)) )  ;剩余数量
        (command "LOT" "Y" "" dyj A? "M" fx "N" "W" pmin pmax "F" "C" "Y" dyys "Y" "N" "N" "N" "Y")
        (princ (strcat "\n还剩 "sysl" 张""\n "))  ;剩余数量
      )
    )
  )
(if(= sysl 0)(alert"已打印 "dyfs" 份，每份"i" 张，共"(* dyfs i)" 张"))
)  ;打印份数

(sssetfirst nil dybj)  ;亮显打印标记

(if (= dy 2)(command "erase" dybj "") )  ;空格删除打印标记

(setq
tzsl '()
dyfs '()
dyj '()
A? '()
dy '()
L? '()
P? '()
)

))
(setq dayin '())
  (princ)
)


(defun dyxx(/ dyaj)  ;打印选项
(princ(strcat"\n共选中 "(itoa (sslength tzsl))" 张图纸,右键打印,左键取消打印保留打印标记,空格取消打并删除打印标记,2~9为打印份数,1为pdf") )
(setq dyaj (grread)) (cond  ;(setq u (grread))回车后按任意键查看键值
((= (car dyaj) 25) (setq dy 1)) ;右键打印
((= (cadr dyaj) 48) (setq dy 1 dyfs(getint"\n请输入打印份数:"))) ;0输入打印份数
((= (cadr dyaj) 32) (setq dy 2))  ;空格取消打并删除打印标记
((= (cadr dyaj) 43) (setq dy 1 A? "A3"))  ;打印A3
((= (cadr dyaj) 49) (setq dy 1 dyj "pdfFactory Pro"))  ;1打印pdf
((= (cadr dyaj) 50) (setq dy 1 dyfs 2))
((= (cadr dyaj) 51) (setq dy 1 dyfs 3))
((= (cadr dyaj) 52) (setq dy 1 dyfs 4))
((= (cadr dyaj) 53) (setq dy 1 dyfs 5))
))

;;;依据多个标准选取物件,可以框选
;;;即可以有多个图层，多个颜色作为标准
;;;然后依据这个标准来框选并自动过滤掉不合标准的物体 upaarx(1295389245) 2014.05.20
(defun sexuan?(/ sys  name1 n1 nSSLen nTotal  lst1 pairLayer pairColor str1 lstF1 lstF2 lstF3 pt1 pt2 nOsmode p1 p2)
(command)(princ)

(setvar 'NOMUTT 1)
(if (= dayin 1)
(progn (princ"\n按颜色选择图框:")(setq sys (ssget":S")) )
(progn (princ"\n按颜色选择对象:")(setq sys (ssget)) ) )
(setvar 'NOMUTT 0)

(if (and (= sys nil)(= dayin 1))(progn (scdybj?) (setq dayin '()) ) );删除打印标记

        (if        (null sys)
                (exit)
        )
        (setq        nSSLen (sslength sys)
                                n1                 0
                                nTotal 0
                                lstF3         (list)
                                lstF1         (list (cons -4 "<OR"))
        )
        (while (< n1 nSSLen)
                (setq        lstF2                        nil
                                        name1                        (ssname sys n1)
                                        lst1                        (entget name1)
                                        pairLayer        (assoc 8 lst1);图层
                                        pairColor        (assoc 62 lst1);颜色
                )
                (if        (null pairColor)
                        (setq pairColor (cons 62 256))
                )
                (setq        lstF2        (list (cons -4 "AND>"))
                                        lstF2        (cons pairColor lstF2)
                                        lstF2        (cons pairLayer lstF2)
                                        lstF2        (cons (cons -4 "<AND") lstF2)
                                        str1        (strcat (cdr pairLayer) (itoa (cdr pairColor)))
                )
                (if        (null (member str1 lstF3))
                        (setq        lstF3        (cons str1 lstF3)
                                                lstF1        (append lstF1 lstF2)
                        )
                )
                (setq nTotal (1+ nTotal))
                (setq n1 (1+ n1))
        ) ;while
        (if        (= 1 nTotal)
                (setq lstF1 (cdr lstF1))
                (setq lstF1 (append lstF1 (list (cons -4 "OR>"))))
        )
(princ"\n请框选对象:")
        (setq ss (ssget lstF1))
(setvar 'NOMUTT 0)
        (princ
                (strcat "\n共选到 " (itoa (sslength ss)) " 个对象")
        )
        (sssetfirst nil ss)
        (princ)
)


(defun scdybj?()  ;删除选择的打印标记
(setvar 'NOMUTT 1)
(princ "\n请选择要删除的打印标记，空选删除当前可见的打印标记:")
(setq sk (ssget))
(setvar 'NOMUTT 0)
(if (= sk nil)
(progn (c:re)(scdybj) ) (scdybj) )
)

(defun scdybj()
(command "undo" "be"
"erase" (ssget "p" '((8 . "3不打印")(62 . 200)(0 . "*text")))""  ;删除文字
"undo" "e") )


;可见区域重生成（hbllw 2010-11-6）
(defun c:re(/ $screen atio ce ch ch2 hh hh2 k p1 p2 dim0 skdim0)
(setq $screen (getvar "screensize"))
(setq ch (getvar "viewsize"))
(setq ch2 (/ ch 2))
(setq ce (getvar "viewctr"))
(setq atio (/ (car $screen) (cadr $screen)))
(setq hh (* atio ch))
(setq hh2 (/ hh 2))
(setq p1 (polar (polar ce 0 hh2)(* 1.5 pi) ch2))
(setq p2 (polar (polar ce pi hh2)(* 0.5 pi) ch2))
(setq sk (ssget "c" p1 p2))
(setq k -1)
(if (= sk nil)(princ"\n没有对象")
(if (and (> (sslength sk) 0)(< (sslength sk) 5001) )
(progn
(repeat (sslength sk)
(entupd (ssname sk (setq k (1+ k)))))
(if (/= wzsl 61)(progn(princ(strcat"\n已刷新 "(itoa(sslength sk))" 个，")) ) )
(setq dim0 (ssget "p" '((0 . "dimension") (42 . 0) ) ) )
(if (/= dim0 nil)(progn
(command "Select" sk "r" dim0 "")(setq skdim0 (ssget ""))
(command "erase" dim0 ""(princ(strcat"\n已刷新 "(itoa(sslength skdim0))" 个， 删除 0 标注 "(itoa(sslength dim0))" 个") ) )
) ) )
(princ(strcat"\n对象已超过 5000 个 （"(itoa(sslength sk))"个）"))
) )
(princ))

言戲無軍

1. (defun c:test(/ ent fx i maxpoint xx0 xy0 minpoint x0 y0 os pmax pmin ptlist dybj bj tcm ys)
   
2. 
   
3.   (vl-load-com)
   
4.   (setvar "cmdecho" 0)
   
5. (setq tzsl(ssadd) dybj(ssadd) )
   
6. 
   
7. ;  (princ "\n请选取要打印的矩形图框:")
   
8. ;  (setq tzsl (ssget (list '(0 . "LWPOLYLINE")'(8 . "图框") '(90 . 4))))
   
9. 
   
10. (setq
    
11. dayin '()
    
12. tzsl '()
    
13. dyfs '()
    
14. dyj '()
    
15. A? '()
    
16. dy '()
    
17. )
    
18. 
    
19. (setq dayin 1)  ;打印调用标记
    
20. (sexuan?)  ;按颜色选择对象
    
21. 
    
22.   (setq tzsl (ssget "p" '((0 . "LWPOLYLINE"))))
    
23. 
    
24. (if (/= tzsl nil)(progn
    
25. 
    
26. (setq tcm "3不打印")  ;图层名
    
27. (setq ys 200)         ;图层颜色
    
28. (if (not (tblsearch "layer" tcm)) (progn ;判断图层是否存在
    
29. (command (setq la (getvar"clayer")) "layer" "m" tcm "C" ys "" "P" "N" "" "" "clayer" la)
    
30. ) )  ;不存在则新建图层
    
31. 
    
32.   (setq n (sslength tzsl) i 0)
    
33.   (setq dybj (ssadd))  ;打印标记集
    
34.   (repeat n
    
35.     (setq ent (ssname tzsl i))
    
36.     (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
    
37.     (setq pmax (vlax-safearray->list maxpoint)  pmin (vlax-safearray->list minpoint)
    
38.                 x0(car pmin)
    
39.             y0(cadr pmin)
    
40.          xx0(car pmax)
    
41.          xy0(cadr pmax)
    
42. )
    
43. (if (= L? nil)(setq L? "L"))  ;打印方向
    
44. (if (= P? nil)(setq P? "P"))  ;打印方向
    
45.     (if (>= (- xx0 x0) (- xy0 y0)) (setq fx L?)(setq fx P?) )
    
46. 
    
47.     (setq ptlist (cons (list pmin pmax fx) ptlist))
    
48.     (setq i (1+ i))
    
49.   )
    
50. 
    
51. 
    
52. (setq ptlist (Order-Pt ptlist))
    
53. 
    
54. 
    
55.       (setq i 0)
    
56.       (repeat (length ptlist)
    
57.         (setq ent (nth i ptlist )  pmin (car ent) pmax (cadr ent) fx (last ent)
    
58.           x0(car pmin)
    
59. y0(cadr pmin)
    
60. xx0(car pmax)
    
61. xy0(cadr pmax)
    
62. )
    
63. 
    
64. 
    
65. 
    
66.     (grdraw (list x0 y0 0) (list xx0 xy0 0) 1 1)  ;临时标记线
    
67.     (grdraw (list x0 xy0 0) (list xx0 y0 0) 1 1)  ;临时标记线
    
68. 
    
69. (if(setq bj(ssget "c" (list x0 y0)(list xx0 xy0)(list '(0 . "*text")(cons 8 tcm)(cons 62 ys)))) (command"erase"bj"") )  ;删除打印标记文字
    
70. (if (> i 98) (setq zigao(*(- xy0 y0)0.66)) (setq zigao(- xy0 y0)) )  ;打印标记文字高度
    
71. (setvar 'osmode 0)  ;关闭捕捉
    
72.     (entmake (list '(0 . "text")(cons 1 (itoa(1+ i)))(cons 10(list x0 y0 0))(cons 40 zigao)(cons 8 tcm)(cons 62 ys) ))  ;写打印标记
    
73. (setvar 'osmode 1)  ;打开捕捉
    
74.     (ssadd (entlast) dybj)  ;打印标记集
    
75. 
    
76. 
    
77. 
    
78.         (setq i (1+ i))
    
79. 
    
80. )
    
81. 
    
82. 
    
83. 
    
84. 
    
85. (dyxx)  ;打印选项设置
    
86. 
    
87. (if (= dyj nil)(setq dyj (xtdyj)) )  ;默认为系统打印机
    
88. (if (= dyys nil)(setq dyys "monochrome.ctb"))  ;打印样式
    
89. (if (= A? nil)(setq A? "A4")) ;纸张选择
    
90. (if (= dyfs nil)(setq dyfs 1))  ;打印份数
    
91. 
    
92. (repeat dyfs
    
93. 
    
94.   (if (= dy 1)
    
95.     (progn
    
96.       (setq i 0)
    
97.       (repeat (length ptlist)
    
98.         (setq ent (nth i ptlist )  pmin (car ent) pmax (cadr ent) fx (last ent))
    
99. (setq i (1+ i))
    
100. (setq sysl (itoa(-(length ptlist)i)) )  ;剩余数量
     
101.         (vl-cmdf "PLOT" "Y" "" dyj A? "M" fx "N" "W" pmin pmax "F" "C" "Y" dyys "Y" "N" "N"  "N"  "Y")  
     
102.      
     
103.         (princ (strcat "\n还剩 "sysl" 张""\n "))  ;剩余数量
     
104.       )
     
105.     )
     
106.   )
     
107. (if(= sysl 0)(alert"已打印 "dyfs" 份，每份"i" 张，共"(* dyfs i)" 张"))
     
108. )  ;打印份数
     
109. 
     
110. (sssetfirst nil dybj)  ;亮显打印标记
     
111. 
     
112. (if (= dy 2)(command "erase" dybj "") )  ;空格删除打印标记
     
113. 
     
114. (setq
     
115. tzsl '()
     
116. dyfs '()
     
117. dyj '()
     
118. A? '()
     
119. dy '()
     
120. L? '()
     
121. P? '()
     
122. )
     
123. 
     
124. ))
     
125. (setq dayin '())
     
126.   (princ)
     
127. )
     
128. 
     
129. 
     
130. 
     
131. 
     
132. 
     
133. (defun Order-Pt (bdlist)           ;左右上下排序点表 by 秋枫(bdlist)
     
134. (setq bdlist (vl-sort bdlist
     
135.   '(lambda (f1 f2 / pmin pmax rt x1 y1 x2 y2 vs)
     
136.           ; x1, y1对应于第一组的图框中心点的坐标
     
137.      (setq pmin (car f1) pmax (cadr f1))
     
138.      (setq x1 (* (+ (car pmin) (car pmax)) 0.5))
     
139.      (setq y1 (* (+ (cadr pmin) (cadr pmax)) 0.5))
     
140. 
     
141.      (setq pmin (car f2) pmax (cadr f2))
     
142.      (setq x2 (* (+ (car pmin) (car pmax)) 0.5))
     
143.      (setq y2 (* (+ (cadr pmin) (cadr pmax)) 0.5))
     
144.       
     
145.      (setq rt (> y1 y2))
     
146.           ;优先Y坐标比较，大的话在前
     
147.      (if  (and (null tr) (equal  y1 y2 1e1))
     
148.           ;Y坐标相同时，比较X坐标，小的话在前
     
149.        (progn
     
150.              (setq rt (< x1 x2))
     
151.              (prompt "相等\n")   
     
152.          )  
     
153.      )
     
154.      rt
     
155.    )
     
156.   )
     
157. )
     
158. 
     
159. bdlist
     
160. )
     
161. 
     
162. 
     
163. (defun dyxx(/ dyaj)  ;打印选项
     
164. (princ(strcat"\n共选中 "(itoa (sslength tzsl))" 张图纸,右键打印,左键取消打印保留打印标记,空格取消打并删除打印标记,2~9为打印份数,1为pdf") )
     
165. (setq dyaj (grread)) (cond  ;(setq u (grread))回车后按任意键查看键值
     
166. ((= (car dyaj) 25) (setq dy 1)) ;右键打印
     
167. ((= (cadr dyaj) 48) (setq dy 1 dyfs(getint"\n请输入打印份数:"))) ;0输入打印份数
     
168. ((= (cadr dyaj) 32) (setq dy 2))  ;空格取消打并删除打印标记
     
169. ((= (cadr dyaj) 43) (setq dy 1 A? "A3"))  ;打印A3
     
170. ((= (cadr dyaj) 49) (setq dy 1 dyj "pdf pdfFactory Pro"))  ;1打印pdf pdfFactory Pro  Microsoft Print to PDF  DWG To PDF
     
171. ((= (cadr dyaj) 50) (setq dy 1 dyfs 2))
     
172. ((= (cadr dyaj) 51) (setq dy 1 dyfs 3))
     
173. ((= (cadr dyaj) 52) (setq dy 1 dyfs 4))
     
174. ((= (cadr dyaj) 53) (setq dy 1 dyfs 5))
     
175. ))
     
176. 
     
177. ;;;依据多个标准选取物件,可以框选
     
178. ;;;即可以有多个图层，多个颜色作为标准
     
179. ;;;然后依据这个标准来框选并自动过滤掉不合标准的物体 upaarx(1295389245) 2014.05.20
     
180. (defun sexuan?(/ sys  name1 n1 nSSLen nTotal  lst1 pairLayer pairColor str1 lstF1 lstF2 lstF3 pt1 pt2 nOsmode p1 p2)
     
181. (command)(princ)
     
182. 
     
183. (setvar 'NOMUTT 1)
     
184. (if (= dayin 1)
     
185. (progn (princ"\n按颜色选择图框:")(setq sys (ssget":S")) )
     
186. (progn (princ"\n按颜色选择对象:")(setq sys (ssget)) ) )
     
187. (setvar 'NOMUTT 0)
     
188. 
     
189. (if (and (= sys nil)(= dayin 1))(progn (scdybj?) (setq dayin '()) ) );删除打印标记
     
190. 
     
191.         (if        (null sys)
     
192.                 (exit)
     
193.         )
     
194.         (setq        nSSLen (sslength sys)
     
195.                                 n1                 0
     
196.                                 nTotal 0
     
197.                                 lstF3         (list)
     
198.                                 lstF1         (list (cons -4 "<OR"))
     
199.         )
     
200.         (while (< n1 nSSLen)
     
201.                 (setq        lstF2                        nil
     
202.                                         name1                        (ssname sys n1)
     
203.                                         lst1                        (entget name1)
     
204.                                         pairLayer        (assoc 8 lst1);图层
     
205.                                         pairColor        (assoc 62 lst1);颜色
     
206.                 )
     
207.                 (if        (null pairColor)
     
208.                         (setq pairColor (cons 62 256))
     
209.                 )
     
210.                 (setq        lstF2        (list (cons -4 "AND>"))
     
211.                                         lstF2        (cons pairColor lstF2)
     
212.                                         lstF2        (cons pairLayer lstF2)
     
213.                                         lstF2        (cons (cons -4 "<AND") lstF2)
     
214.                                         str1        (strcat (cdr pairLayer) (itoa (cdr pairColor)))
     
215.                 )
     
216.                 (if        (null (member str1 lstF3))
     
217.                         (setq        lstF3        (cons str1 lstF3)
     
218.                                                 lstF1        (append lstF1 lstF2)
     
219.                         )
     
220.                 )
     
221.                 (setq nTotal (1+ nTotal))
     
222.                 (setq n1 (1+ n1))
     
223.         ) ;while
     
224.         (if        (= 1 nTotal)
     
225.                 (setq lstF1 (cdr lstF1))
     
226.                 (setq lstF1 (append lstF1 (list (cons -4 "OR>"))))
     
227.         )
     
228. (princ"\n请框选对象:")
     
229.         (setq ss (ssget lstF1))
     
230. (setvar 'NOMUTT 0)
     
231.         (princ
     
232.                 (strcat "\n共选到 " (itoa (sslength ss)) " 个对象")
     
233.         )
     
234.         (sssetfirst nil ss)
     
235.         (princ)
     
236. )
     
237. 
     
238. 
     
239. (defun scdybj?()  ;删除选择的打印标记
     
240. (setvar 'NOMUTT 1)
     
241. (princ "\n请选择要删除的打印标记，空选删除当前可见的打印标记:")
     
242. (setq sk (ssget))
     
243. (setvar 'NOMUTT 0)
     
244. (if (= sk nil)
     
245. (progn (c:re)(scdybj) ) (scdybj) )
     
246. )
     
247. 
     
248. (defun scdybj()
     
249. (command "undo" "be"
     
250. "erase" (ssget "p" '((8 . "3不打印")(62 . 200)(0 . "*text")))""  ;删除文字
     
251. "undo" "e") )
     
252. 
     
253. 
     
254. ;可见区域重生成（hbllw 2010-11-6）
     
255. (defun c:re(/ $screen atio ce ch ch2 hh hh2 k p1 p2 dim0 skdim0)
     
256. (setq $screen (getvar "screensize"))
     
257. (setq ch (getvar "viewsize"))
     
258. (setq ch2 (/ ch 2))
     
259. (setq ce (getvar "viewctr"))
     
260. (setq atio (/ (car $screen) (cadr $screen)))
     
261. (setq hh (* atio ch))
     
262. (setq hh2 (/ hh 2))
     
263. (setq p1 (polar (polar ce 0 hh2)(* 1.5 pi) ch2))
     
264. (setq p2 (polar (polar ce pi hh2)(* 0.5 pi) ch2))
     
265. (setq sk (ssget "c" p1 p2))
     
266. (setq k -1)
     
267. (if (= sk nil)(princ"\n没有对象")
     
268. (if (and (> (sslength sk) 0)(< (sslength sk) 5001) )
     
269. (progn
     
270. (repeat (sslength sk)
     
271. (entupd (ssname sk (setq k (1+ k)))))
     
272. (if (/= wzsl 61)(progn(princ(strcat"\n已刷新 "(itoa(sslength sk))" 个，")) ) )
     
273. (setq dim0 (ssget "p" '((0 . "dimension") (42 . 0) ) ) )
     
274. (if (/= dim0 nil)(progn
     
275. (command "Select" sk "r" dim0 "")(setq skdim0 (ssget "p"))
     
276. (command "erase" dim0 ""(princ(strcat"\n已刷新 "(itoa(sslength skdim0))" 个， 删除 0 标注 "(itoa(sslength dim0))" 个") ) )
     
277. ) ) )
     
278. (princ(strcat"\n对象已超过 5000 个 （"(itoa(sslength sk))"个）"))
     
279. ) )
     
280. (princ))
     

(defun c:test(/ ent fx i maxpoint xx0 xy0 minpoint x0 y0 os pmax pmin ptlist dybj bj tcm ys)<br /> <br />   (vl-load-com)<br />   (setvar "cmdecho" 0)<br /> (setq tzsl(ssadd) dybj(ssadd) )<br /> <br /> ;  (princ "\n请选取要打印的矩形图框:")<br /> ;  (setq tzsl (ssget (list '(0 . "LWPOLYLINE")'(8 . "图框") '(90 . 4))))<br /> <br /> (setq<br /> dayin '()<br /> tzsl '()<br /> dyfs '()<br /> dyj '()<br /> A? '()<br /> dy '()<br /> )<br /> <br /> (setq dayin 1)  ;打印调用标记<br /> (sexuan?)  ;按颜色选择对象<br /> <br />   (setq tzsl (ssget "p" '((0 . "LWPOLYLINE"))))<br /> <br /> (if (/= tzsl nil)(progn<br /> <br /> (setq tcm "3不打印")  ;图层名<br /> (setq ys 200)         ;图层颜色<br /> (if (not (tblsearch "layer" tcm)) (progn ;判断图层是否存在<br /> (command (setq la (getvar"clayer")) "layer" "m" tcm "C" ys "" "P" "N" "" "" "clayer" la)<br /> ) )  ;不存在则新建图层<br /> <br />   (setq n (sslength tzsl) i 0)<br />   (setq dybj (ssadd))  ;打印标记集<br />   (repeat n<br />     (setq ent (ssname tzsl i))<br />     (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)<br />     (setq pmax (vlax-safearray->list maxpoint)  pmin (vlax-safearray->list minpoint)<br />                 x0(car pmin)<br />             y0(cadr pmin)<br />          xx0(car pmax)<br />          xy0(cadr pmax)<br /> )<br /> (if (= L? nil)(setq L? "L"))  ;打印方向<br /> (if (= P? nil)(setq P? "P"))  ;打印方向<br />     (if (>= (- xx0 x0) (- xy0 y0)) (setq fx L?)(setq fx P?) )<br /> <br />     (setq ptlist (cons (list pmin pmax fx) ptlist))<br />     (setq i (1+ i))<br />   )<br /> <br /> <br /> (setq ptlist (Order-Pt ptlist))<br /> <br /> <br />       (setq i 0)<br />       (repeat (length ptlist)<br />         (setq ent (nth i ptlist )  pmin (car ent) pmax (cadr ent) fx (last ent)<br />           x0(car pmin)<br /> y0(cadr pmin)<br /> xx0(car pmax)<br /> xy0(cadr pmax)<br /> )<br /> <br /> <br /> <br />     (grdraw (list x0 y0 0) (list xx0 xy0 0) 1 1)  ;临时标记线<br />     (grdraw (list x0 xy0 0) (list xx0 y0 0) 1 1)  ;临时标记线<br /> <br /> (if(setq bj(ssget "c" (list x0 y0)(list xx0 xy0)(list '(0 . "*text")(cons 8 tcm)(cons 62 ys)))) (command"erase"bj"") )  ;删除打印标记文字<br /> (if (> i 98) (setq zigao(*(- xy0 y0)0.66)) (setq zigao(- xy0 y0)) )  ;打印标记文字高度<br /> (setvar 'osmode 0)  ;关闭捕捉<br />     (entmake (list '(0 . "text")(cons 1 (itoa(1+ i)))(cons 10(list x0 y0 0))(cons 40 zigao)(cons 8 tcm)(cons 62 ys) ))  ;写打印标记<br /> (setvar 'osmode 1)  ;打开捕捉<br />     (ssadd (entlast) dybj)  ;打印标记集<br /> <br /> <br /> <br />         (setq i (1+ i))<br /> <br /> )<br /> <br /> <br /> <br /> <br /> (dyxx)  ;打印选项设置<br /> <br /> (if (= dyj nil)(setq dyj (xtdyj)) )  ;默认为系统打印机<br /> (if (= dyys nil)(setq dyys "monochrome.ctb"))  ;打印样式<br /> (if (= A? nil)(setq A? "A4")) ;纸张选择<br /> (if (= dyfs nil)(setq dyfs 1))  ;打印份数<br /> <br /> (repeat dyfs<br /> <br />   (if (= dy 1)<br />     (progn<br />       (setq i 0)<br />       (repeat (length ptlist)<br />         (setq ent (nth i ptlist )  pmin (car ent) pmax (cadr ent) fx (last ent))<br /> (setq i (1+ i))<br /> (setq sysl (itoa(-(length ptlist)i)) )  ;剩余数量<br />         (vl-cmdf "PLOT" "Y" "" dyj A? "M" fx "N" "W" pmin pmax "F" "C" "Y" dyys "Y" "N" "N"  "N"  "Y")  <br />      <br />         (princ (strcat "\n还剩 "sysl" 张""\n "))  ;剩余数量<br />       )<br />     )<br />   )<br /> (if(= sysl 0)(alert"已打印 "dyfs" 份，每份"i" 张，共"(* dyfs i)" 张"))<br /> )  ;打印份数<br /> <br /> (sssetfirst nil dybj)  ;亮显打印标记<br /> <br /> (if (= dy 2)(command "erase" dybj "") )  ;空格删除打印标记<br /> <br /> (setq<br /> tzsl '()<br /> dyfs '()<br /> dyj '()<br /> A? '()<br /> dy '()<br /> L? '()<br /> P? '()<br /> )<br /> <br /> ))<br /> (setq dayin '())<br />   (princ)<br /> )<br /> <br /> <br /> <br /> <br /> <br /> (defun Order-Pt (bdlist)           ;左右上下排序点表 by 秋枫(bdlist)<br /> (setq bdlist (vl-sort bdlist<br />   '(lambda (f1 f2 / pmin pmax rt x1 y1 x2 y2 vs)<br />           ; x1, y1对应于第一组的图框中心点的坐标<br />      (setq pmin (car f1) pmax (cadr f1))<br />      (setq x1 (* (+ (car pmin) (car pmax)) 0.5))<br />      (setq y1 (* (+ (cadr pmin) (cadr pmax)) 0.5))<br /> <br />      (setq pmin (car f2) pmax (cadr f2))<br />      (setq x2 (* (+ (car pmin) (car pmax)) 0.5))<br />      (setq y2 (* (+ (cadr pmin) (cadr pmax)) 0.5))<br />       <br />      (setq rt (> y1 y2))<br />           ;优先Y坐标比较，大的话在前<br />      (if  (and (null tr) (equal  y1 y2 1e1))<br />           ;Y坐标相同时，比较X坐标，小的话在前<br />        (progn<br />              (setq rt (< x1 x2))<br />              (prompt "相等\n")   <br />          )  <br />      )<br />      rt<br />    )<br />   )<br /> )<br /> <br /> bdlist<br /> )<br /> <br /> <br /> (defun dyxx(/ dyaj)  ;打印选项<br /> (princ(strcat"\n共选中 "(itoa (sslength tzsl))" 张图纸,右键打印,左键取消打印保留打印标记,空格取消打并删除打印标记,2~9为打印份数,1为pdf") )<br /> (setq dyaj (grread)) (cond  ;(setq u (grread))回车后按任意键查看键值<br /> ((= (car dyaj) 25) (setq dy 1)) ;右键打印<br /> ((= (cadr dyaj) 48) (setq dy 1 dyfs(getint"\n请输入打印份数:"))) ;0输入打印份数<br /> ((= (cadr dyaj) 32) (setq dy 2))  ;空格取消打并删除打印标记<br /> ((= (cadr dyaj) 43) (setq dy 1 A? "A3"))  ;打印A3<br /> ((= (cadr dyaj) 49) (setq dy 1 dyj "pdf pdfFactory Pro"))  ;1打印pdf pdfFactory Pro  Microsoft Print to PDF  DWG To PDF<br /> ((= (cadr dyaj) 50) (setq dy 1 dyfs 2))<br /> ((= (cadr dyaj) 51) (setq dy 1 dyfs 3))<br /> ((= (cadr dyaj) 52) (setq dy 1 dyfs 4))<br /> ((= (cadr dyaj) 53) (setq dy 1 dyfs 5))<br /> ))<br /> <br /> ;;;依据多个标准选取物件,可以框选<br /> ;;;即可以有多个图层，多个颜色作为标准<br /> ;;;然后依据这个标准来框选并自动过滤掉不合标准的物体 upaarx(1295389245) 2014.05.20 <br /> (defun sexuan?(/ sys  name1 n1 nSSLen nTotal  lst1 pairLayer pairColor str1 lstF1 lstF2 lstF3 pt1 pt2 nOsmode p1 p2)<br /> (command)(princ)<br /> <br /> (setvar 'NOMUTT 1)<br /> (if (= dayin 1)<br /> (progn (princ"\n按颜色选择图框:")(setq sys (ssget":S")) )<br /> (progn (princ"\n按颜色选择对象:")(setq sys (ssget)) ) )<br /> (setvar 'NOMUTT 0)<br /> <br /> (if (and (= sys nil)(= dayin 1))(progn (scdybj?) (setq dayin '()) ) );删除打印标记<br /> <br />         (if        (null sys)<br />                 (exit)<br />         )<br />         (setq        nSSLen (sslength sys)<br />                                 n1                 0<br />                                 nTotal 0<br />                                 lstF3         (list)<br />                                 lstF1         (list (cons -4 "<OR"))<br />         )<br />         (while (< n1 nSSLen)<br />                 (setq        lstF2                        nil<br />                                         name1                        (ssname sys n1)<br />                                         lst1                        (entget name1)<br />                                         pairLayer        (assoc 8 lst1);图层<br />                                         pairColor        (assoc 62 lst1);颜色<br />                 )<br />                 (if        (null pairColor)<br />                         (setq pairColor (cons 62 256))<br />                 )<br />                 (setq        lstF2        (list (cons -4 "AND>"))<br />                                         lstF2        (cons pairColor lstF2)<br />                                         lstF2        (cons pairLayer lstF2)<br />                                         lstF2        (cons (cons -4 "<AND") lstF2)<br />                                         str1        (strcat (cdr pairLayer) (itoa (cdr pairColor)))<br />                 )<br />                 (if        (null (member str1 lstF3))<br />                         (setq        lstF3        (cons str1 lstF3)<br />                                                 lstF1        (append lstF1 lstF2)<br />                         )<br />                 )<br />                 (setq nTotal (1+ nTotal))<br />                 (setq n1 (1+ n1))<br />         ) ;while<br />         (if        (= 1 nTotal)<br />                 (setq lstF1 (cdr lstF1))<br />                 (setq lstF1 (append lstF1 (list (cons -4 "OR>"))))<br />         )<br /> (princ"\n请框选对象:")<br />         (setq ss (ssget lstF1))<br /> (setvar 'NOMUTT 0)<br />         (princ<br />                 (strcat "\n共选到 " (itoa (sslength ss)) " 个对象")<br />         )<br />         (sssetfirst nil ss)<br />         (princ)<br /> )<br /> <br /> <br /> (defun scdybj?()  ;删除选择的打印标记<br /> (setvar 'NOMUTT 1)<br /> (princ "\n请选择要删除的打印标记，空选删除当前可见的打印标记:")<br /> (setq sk (ssget))<br /> (setvar 'NOMUTT 0)<br /> (if (= sk nil)<br /> (progn (c:re)(scdybj) ) (scdybj) )<br /> )<br /> <br /> (defun scdybj()<br /> (command "undo" "be"<br /> "erase" (ssget "p" '((8 . "3不打印")(62 . 200)(0 . "*text")))""  ;删除文字<br /> "undo" "e") )<br /> <br /> <br /> ;可见区域重生成（hbllw 2010-11-6）<br /> (defun c:re(/ $screen atio ce ch ch2 hh hh2 k p1 p2 dim0 skdim0)<br /> (setq $screen (getvar "screensize"))<br /> (setq ch (getvar "viewsize"))<br /> (setq ch2 (/ ch 2))<br /> (setq ce (getvar "viewctr"))<br /> (setq atio (/ (car $screen) (cadr $screen)))<br /> (setq hh (* atio ch))<br /> (setq hh2 (/ hh 2))<br /> (setq p1 (polar (polar ce 0 hh2)(* 1.5 pi) ch2))<br /> (setq p2 (polar (polar ce pi hh2)(* 0.5 pi) ch2))<br /> (setq sk (ssget "c" p1 p2))<br /> (setq k -1)<br /> (if (= sk nil)(princ"\n没有对象")<br /> (if (and (> (sslength sk) 0)(< (sslength sk) 5001) )<br /> (progn<br /> (repeat (sslength sk)<br /> (entupd (ssname sk (setq k (1+ k)))))<br /> (if (/= wzsl 61)(progn(princ(strcat"\n已刷新 "(itoa(sslength sk))" 个，")) ) )<br /> (setq dim0 (ssget "p" '((0 . "dimension") (42 . 0) ) ) )<br /> (if (/= dim0 nil)(progn<br /> (command "Select" sk "r" dim0 "")(setq skdim0 (ssget "p"))<br /> (command "erase" dim0 ""(princ(strcat"\n已刷新 "(itoa(sslength skdim0))" 个， 删除 0 标注 "(itoa(sslength dim0))" 个") ) )<br /> ) ) )<br /> (princ(strcat"\n对象已超过 5000 个 （"(itoa(sslength sk))"个）"))<br /> ) )<br /> (princ))<br />

669423907

;获取系统打印机 simpleye 2013.03.23
(defun xtdyj(/ device)
(vl-load-com)(substr (setq device(vl-registry-read
"HKEY_CURRENT_USER\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Windows" "Device"))1(vl-string-search "," device)))

669423907

顶起，求助啊

sunny_8848

静候楼主佳音

xyp1964

669423907

xyp1964 发表于 2018-3-12 08:20

院长好厉害耶，方便帮改一下么？

sunny_8848

关注下，静待完善，这个文件方便实用

669423907

求助，顶起一下

yxl88168

秋枫打印不是可以吗，借鉴一下