HATCH相关处理的一些代码

Lisphk

提供的工具：
1、HatchDelALL
  删除所有的填充实体

2、HatchDelSEL

  删除选择的填充实体

3、Hatch2LayALL

  所有填充移动到图层

4、Hatch2LaySEL

  移动选择的填充到图层

1. (vl-load-com)
   
2. (defun C:HatchDelALL () (work-whith-all-hatch nil))
   
3. (defun C:HatchDelSEL ()
   
4. (work-whith-selected-hatch
   
5.    nil
   
6.    (msg-yes-no "Select" "Delete associative polylines?")
   
7.    )
   
8. )
   
9. (defun C:Hatch2LayALL (/ lay)
   
10. ;;; ALL Hatch to Layer
    
11. (if
    
12.    (setq lay (mydcl "Select Layers"
    
13.                     (vl-remove-if-not
    
14.                       'snvalid
    
15.                       (acad_strlsort (tablelist "Layer"))
    
16.                     ) ;_ end of vl-remove-if-not
    
17.              ) ;_ end of mydcl
    
18.    ) ;_ end of setq
    
19.     (progn
    
20.       (work-whith-all-hatch (car lay))
    
21.       (princ "\nDone!")
    
22.       (princ)
    
23.     ) ;_ end of progn
    
24. ) ;_ end of if
    
25. ) ;_ end of defun
    
26. (defun C:Hatch2LaySEL (/ lay)
    
27. ;;; Selected Hatch to Layer
    
28. (if
    
29.    (setq lay (mydcl "Select Layers"
    
30.                     (vl-remove-if-not
    
31.                       'snvalid
    
32.                       (acad_strlsort (tablelist "Layer"))
    
33.                     ) ;_ end of vl-remove-if-not
    
34.              ) ;_ end of mydcl
    
35.    ) ;_ end of setq
    
36.     (progn
    
37.       (work-whith-selected-hatch
    
38.         (car lay)
    
39.         (msg-yes-no "Select" "Move to layer associative polylines?")
    
40.         )
    
41.       (princ "\nDone!")
    
42.       (princ)
    
43.     ) ;_ end of progn
    
44. ) ;_ end of if
    
45. ) ;_ end of defun
    
46. 
    
47. (defun work-whith-all-hatch
    
48.       (what / adoc *error* poly _loc-delete-or-move-items)
    
49. ;;; what - nil - delete
    
50. ;;;      - string - layer to move
    
51. (defun *error* (msg)
    
52.    (setvar "MODEMACRO" "")
    
53.    (princ msg)
    
54.    (vla-regen aDOC acactiveviewport)
    
55.    (bg:progress-clear)
    
56.    (bg:layer-status-restore)
    
57.    (vla-endundomark aDOC)
    
58.    (princ)
    
59. ) ;_ end of defun
    
60. (defun _loc-delete-or-move-items (Blk)
    
61.    (if (= (vla-get-isxref Blk) :vlax-false)
    
62.      (progn
    
63.        (if (> (vla-get-count Blk) 100)
    
64.          (bg:progress-init
    
65.            (strcat (vla-get-name Blk) " :")
    
66.            (vla-get-count Blk)
    
67.          ) ;_ end of bg:progress-init
    
68.          (progn
    
69.            (setvar "MODEMACRO" (vla-get-name Blk))
    
70.          ) ;_ end of progn
    
71.        ) ;_ end of if
    
72.        (vlax-for Obj Blk
    
73.          (if (= (vla-get-objectname Obj) "AcDbHatch")
    
74.            (progn
    
75.              (if (and what (eq (type what) 'STR))
    
76.                (vl-catch-all-apply 'vla-put-layer (list Obj what))
    
77.                (vl-catch-all-apply 'vla-delete (list Obj))
    
78.              ) ;_ end of if
    
79.            ) ;_ end of progn
    
80.          ) ;_ end of if
    
81.        ) ;_ end of vlax-for
    
82.        (bg:progress-clear)
    
83.      ) ;_ end of progn
    
84.    ) ;_ end of if
    
85. ) ;_ end of defun
    
86. (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))
    
87. (vla-startundomark aDOC)
    
88. (if (and (eq (type what) 'STR)
    
89.           (not (tblobjname "LAYER" what))
    
90.      ) ;_ end of and
    
91.    (vla-add (vla-get-layers aDOC) what)
    
92. ) ;_ end of if
    
93. (bg:layer-status-save)
    
94. (vlax-for Blk (vla-get-blocks aDOC)
    
95.    (_loc-delete-or-move-items Blk)
    
96. ) ;_ end of vlax-for
    
97. (bg:layer-status-restore)
    
98. (vla-endundomark aDOC)
    
99. (vla-regen aDOC acactiveviewport)
    
100. (princ)
     
101. ) ;_ end of defun
     
102. (defun work-whith-selected-hatch
     
103.       (what assocpoly / adoc *error* ss lst poly _loc-delete-items)
     
104. ;;; what - nil - delete
     
105. ;;;      - string - layer to move
     
106. ;;; assocpoly - t - move associated poly
     
107. ;;;            nil - not
     
108. (defun *error* (msg)
     
109.    (setvar "MODEMACRO" "")
     
110.    (princ msg)
     
111.    (vla-regen aDOC acactiveviewport)
     
112.    (bg:progress-clear)
     
113.    (bg:layer-status-restore)
     
114.    (vla-endundomark aDOC)
     
115.    (princ)
     
116. ) ;_ end of defun
     
117. (defun _loc-delete-items (Blk)
     
118.    (if (= (vla-get-isxref Blk) :vlax-false)
     
119.      (progn
     
120.        (setq count 0)
     
121.        (if (> (vla-get-count Blk) 100)
     
122.          (bg:progress-init
     
123.            (strcat (vla-get-name Blk) " :")
     
124.            (vla-get-count Blk)
     
125.          ) ;_ end of bg:progress-init
     
126.          (progn
     
127.            (setvar "MODEMACRO" (vla-get-name Blk))
     
128.          ) ;_ end of progn
     
129.        ) ;_ end of if
     
130.        (vlax-for Obj Blk
     
131.          (if (= (vla-get-objectname Obj) "AcDbHatch")
     
132.            (progn
     
133. ;;; >>>>> Associated entities begin
     
134.              (if assocpoly
     
135.              (setq poly
     
136.                         (mapcar 'cdr
     
137.                                 (vl-remove-if-not
     
138.                                   '(lambda (x) (= (car x) 330))
     
139.                                   (entget (vlax-vla-object->ename Obj))
     
140.                                 ) ;_ end of vl-remove-if-not
     
141.                         ) ;_ end of mapcar
     
142.                    poly (vl-remove-if-not
     
143.                           '(lambda (x)
     
144.                              (wcmatch (cdr (assoc 0 (entget x)))
     
145.                                       "*LINE,CIRCLE,ELLIPSE"
     
146.                              ) ;_ end of wcmatch
     
147.                            ) ;_ end of lambda
     
148.                           poly
     
149.                         ) ;_ end of vl-remove-if-not
     
150.              ) ;_ end of setq
     
151.              (setq poly nil)  
     
152.                )
     
153. ;;; <<<<<< Associated entities end
     
154.              (if (and what (eq (type what) 'STR))
     
155.                (mapcar
     
156.                  '(lambda (x)
     
157.                     (vl-catch-all-apply 'vla-put-layer (list x what))
     
158.                   ) ;_ end of lambda
     
159.                  (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))
     
160.                ) ;_ end of mapcar
     
161.                (mapcar '(lambda (x)
     
162.                           (vl-catch-all-apply 'vla-delete (list x))
     
163.                         ) ;_ end of lambda
     
164.                        (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))
     
165.                ) ;_ end of mapcar
     
166.              ) ;_ end of if
     
167.            ) ;_ end of progn
     
168.          ) ;_ end of if
     
169.        ) ;_ end of vlax-for
     
170.        (bg:progress-clear)
     
171.      ) ;_ end of progn
     
172.    ) ;_ end of if
     
173. ) ;_ end of defun
     
174. (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))
     
175. (vla-startundomark aDOC)
     
176. (if (and (eq (type what) 'STR)
     
177.           (not (tblobjname "LAYER" what))
     
178.      ) ;_ end of and
     
179.    (vla-add (vla-get-layers aDOC) what)
     
180. ) ;_ end of if
     
181. (if (and
     
182.        (setq ss (ssget "_:L" '((0 . "HATCH,INSERT"))))
     
183.        (setq lst (mapcar 'vlax-ename->vla-object (pickset-to-list ss)))
     
184.      ) ;_ end of and
     
185.    (progn
     
186.      (bg:layer-status-save)
     
187.      (foreach obj lst
     
188.        (cond
     
189.          ((= (vla-get-objectname Obj) "AcDbHatch")
     
190.          (if  assocpoly
     
191.           (setq poly
     
192.                      (mapcar 'cdr
     
193.                              (vl-remove-if-not
     
194.                                '(lambda (x) (= (car x) 330))
     
195.                                (entget (vlax-vla-object->ename Obj))
     
196.                              ) ;_ end of vl-remove-if-not
     
197.                      ) ;_ end of mapcar
     
198.                 poly (vl-remove-if-not
     
199.                        '(lambda (x)
     
200.                           (wcmatch (cdr (assoc 0 (entget x)))
     
201.                                    "*LINE,CIRCLE,ELLIPSE"
     
202.                           ) ;_ end of wcmatch
     
203.                         ) ;_ end of lambda
     
204.                        poly
     
205.                      ) ;_ end of vl-remove-if-not
     
206.           ) ;_ end of setq
     
207.           (setq poly nil)
     
208.           )
     
209.           (if (and what (eq (type what) 'STR))
     
210.             (mapcar '(lambda (x)
     
211.                        (vl-catch-all-apply 'vla-put-layer (list x what))
     
212.                      ) ;_ end of lambda
     
213.                      (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))
     
214.             ) ;_ end of mapcar
     
215.             (mapcar
     
216.               '(lambda (x) (vl-catch-all-apply 'vla-delete (list x)))
     
217.               (cons Obj (mapcar 'vlax-ename->vla-object poly))
     
218.             ) ;_ end of mapcar
     
219.           )
     
220.          )
     
221.          ((and
     
222.             (= (vla-get-objectname Obj) "AcDbBlockReference")
     
223.             (= (vla-get-isxref
     
224.                  (setq Blk (vla-item (vla-get-blocks aDOC)
     
225.                                      (vla-get-effectivename Obj)
     
226.                            ) ;_ end of vla-item
     
227.                  ) ;_ end of setq
     
228.                ) ;_ end of vla-get-IsXref
     
229.                :vlax-false
     
230.             ) ;_ end of =
     
231.           ) ;_ end of and
     
232.           (_loc-delete-items Blk)
     
233.          )
     
234.          (t nil)
     
235.        ) ;_ end of cond
     
236.      ) ;_ end of foreach
     
237.      (bg:layer-status-restore)
     
238.    ) ;_ end of progn
     
239. ) ;_ end of if
     
240. (vla-endundomark aDOC)
     
241. (vla-regen aDOC acactiveviewport)
     
242. (princ)
     
243. ) ;_ end of defun
     
244. (defun bg:layer-status-restore ()
     
245. (foreach item *BG_LAYER_LST*
     
246.    (if (not (vlax-erased-p (car item)))
     
247.      (vl-catch-all-apply
     
248.        '(lambda ()
     
249.           (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
     
250.           (vla-put-freeze
     
251.             (car item)
     
252.             (cdr (assoc "freeze" (cdr item)))
     
253.           ) ;_ end of vla-put-freeze
     
254.         ) ;_ end of lambda
     
255.      ) ;_ end of vl-catch-all-apply
     
256.    ) ;_ end of if
     
257. ) ;_ end of foreach
     
258. (setq *BG_LAYER_LST* nil)
     
259. ) ;_ end of defun
     
260. 
     
261. (defun bg:layer-status-save ()
     
262. (setq *BG_LAYER_LST* nil)
     
263. (vlax-for item (vla-get-layers
     
264.                   (vla-get-activedocument (vlax-get-acad-object))
     
265.                 ) ;_ end of vla-get-layers
     
266.    (setq *BG_LAYER_LST*
     
267.           (cons (list item
     
268.                       (cons "freeze" (vla-get-freeze item))
     
269.                       (cons "lock" (vla-get-lock item))
     
270.                 ) ;_ end of cons
     
271.                 *BG_LAYER_LST*
     
272.           ) ;_ end of cons
     
273.    ) ;_ end of setq
     
274.    (vla-put-lock item :vlax-false)
     
275.    (if (= (vla-get-freeze item) :vlax-true)
     
276.      (vl-catch-all-apply
     
277.        '(lambda () (vla-put-freeze item :vlax-false))
     
278.      ) ;_ end of vl-catch-all-apply
     
279.    ) ;_ end of if
     
280. ) ;_ end of vlax-for
     
281. ) ;_ end of defun
     
282. (defun bg:progress-init (msg maxlen)
     
283. ;;; msg - niiauaiea eee ionoay no?iea
     
284. ;;; maxlen - iaeneiaeuiia eiee?anoai
     
285. (setq *BG:PROGRESS:OM* (getvar "MODEMACRO"))
     
286. (setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))
     
287. (setq *BG:PROGRESS:MAXLEN* maxlen)
     
288. (setq *BG:PROGRESS:LPS* '-1)
     
289. (princ)
     
290. ) ;_ end of defun
     
291. (defun bg:progress (currvalue / persent str1 count)
     
292. (if *BG:PROGRESS:MAXLEN*
     
293.    (progn
     
294.      (setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))
     
295. ;;;Ea?aua 5 %
     
296.      (setq count (fix (* persent 0.2)))
     
297.      (setq str1 "")
     
298.      (if (/= count *BG:PROGRESS:LPS*)
     
299.        (progn
     
300.          ;;(setq str1 "")
     
301.          (repeat persent (setq str1 (strcat str1 "|")))
     
302.        ) ;_ end of progn
     
303.      ) ;_ end of if
     
304. ;;; currvalue - oaeouaa cia?aiea
     
305.      (setvar "MODEMACRO"
     
306.              (strcat (vl-princ-to-string *BG:PROGRESS:MSG*)
     
307.                      " "
     
308.                      (itoa persent)
     
309.                      " % "
     
310.                      str1
     
311.              ) ;_ end of strcat
     
312.      ) ;_ end of setvar
     
313.      (setq *BG:PROGRESS:LPS* persent)
     
314.    ) ;_ end of progn
     
315. ) ;_ end of if
     
316. ) ;_ end of defun
     
317. 
     
318. (defun bg:progress-clear ()
     
319. (setq *BG:PROGRESS:MSG* nil)
     
320. (setq *BG:PROGRESS:MAXLEN* nil)
     
321. (setq *BG:PROGRESS:LPS* nil)
     
322. (setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))
     
323. ;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
     
324. (princ)
     
325. ) ;_ end of defun
     
326. (defun mydcl (zagl info-list / fl ret dcl_id msg)
     
327. (vl-load-com)
     
328. (if (null zagl)
     
329.    (setq zagl "Select")
     
330. ) ;_ end if
     
331. (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
     
332. (setq ret (open fl "w"))
     
333. (mapcar '(lambda (x) (write-line x ret))
     
334.          (list "mip_msg : dialog { "
     
335.                (strcat "label=\"" zagl "\";")
     
336.                " :list_box {"
     
337.                "alignment=top ;"
     
338.                "multiple_select = true ;"
     
339.                "width=31 ;"
     
340.                (if (> (length info-list) 26)
     
341.                  "height= 26 ;"
     
342.                  (strcat "height= " (itoa (+ 3 (length info-list))) ";")
     
343.                ) ;_ end of if
     
344.                "is_tab_stop = false ;"
     
345.                "key = \"info\";}"
     
346.                "ok_cancel;}"
     
347.          ) ;_ end of list
     
348. ) ;_ end of mapcar
     
349. (setq ret (close ret))
     
350. (if (and (null (minusp (setq dcl_id (load_dialog fl))))
     
351.           (new_dialog "mip_msg" dcl_id)
     
352.      ) ;_ end and
     
353.    (progn (start_list "info")
     
354.           (mapcar 'add_list info-list)
     
355.           (end_list)
     
356.           (set_tile "info" "0")
     
357.           (setq ret "0")
     
358.           (action_tile "info" "(setq ret $value)")
     
359.           (action_tile "cancel" "(done_dialog 0)")
     
360.           (action_tile "accept" " (done_dialog 1)")
     
361.           (if (zerop (start_dialog))
     
362.             (setq ret nil)
     
363.             (setq
     
364.               ret (mapcar (function (lambda (num) (nth num info-list)))
     
365.                           (read (strcat "(" ret ")"))
     
366.                   ) ;_ end mapcar
     
367.             ) ;_ end setq
     
368.           ) ;_ end if
     
369.           (unload_dialog dcl_id)
     
370.    ) ;_ end of progn
     
371. ) ;_ end of if
     
372. (vl-file-delete fl)
     
373. ret
     
374. ) ;_ end of defun
     
375. (defun tablelist (s / d r)
     
376. (while (setq d (tblnext s (null d)))
     
377.    (setq r (cons (cdr (assoc 2 d)) r))
     
378. ) ;_while
     
379. ) ;_defun
     
380. (defun pickset-to-list (value / lst item)
     
381. (repeat (setq item (sslength value)) ;_ end setq
     
382.    (setq lst (cons (ssname value (setq item (1- item))) lst))
     
383. ) ;_ end repeat
     
384. lst
     
385. ) ;_ end of defun
     
386. 
     
387. (defun msg-yes-no ( title message / WScript ret)
     
388. (setq WScript (vlax-get-or-create-object "WScript.Shell"))
     
389. (setq ret (vlax-invoke-method WScript "Popup" message "0" title (+ 4 48)))
     
390. (if WScript (vlax-release-object WScript))
     
391. (= ret 6)  
     
392. )
     
393. (princ
     
394. "\nType HatchDelALL, HatchDelSEL, Hatch2LayALL, Hatch2LaySel in command line"
     
395. ) ;_ end of princ
     
396. (princ)
     
397. 
     

(vl-load-com)<br /> (defun C:HatchDelALL () (work-whith-all-hatch nil))<br /> (defun C:HatchDelSEL ()<br /> (work-whith-selected-hatch<br />    nil<br />    (msg-yes-no "Select" "Delete associative polylines?")<br />    )<br /> )<br /> (defun C:Hatch2LayALL (/ lay)<br /> ;;; ALL Hatch to Layer<br /> (if<br />    (setq lay (mydcl "Select Layers"<br />                     (vl-remove-if-not<br />                       'snvalid<br />                       (acad_strlsort (tablelist "Layer"))<br />                     ) ;_ end of vl-remove-if-not<br />              ) ;_ end of mydcl<br />    ) ;_ end of setq<br />     (progn<br />       (work-whith-all-hatch (car lay))<br />       (princ "\nDone!")<br />       (princ)<br />     ) ;_ end of progn<br /> ) ;_ end of if<br /> ) ;_ end of defun<br /> (defun C:Hatch2LaySEL (/ lay)<br /> ;;; Selected Hatch to Layer<br /> (if<br />    (setq lay (mydcl "Select Layers"<br />                     (vl-remove-if-not<br />                       'snvalid<br />                       (acad_strlsort (tablelist "Layer"))<br />                     ) ;_ end of vl-remove-if-not<br />              ) ;_ end of mydcl<br />    ) ;_ end of setq<br />     (progn<br />       (work-whith-selected-hatch<br />         (car lay)<br />         (msg-yes-no "Select" "Move to layer associative polylines?")<br />         )<br />       (princ "\nDone!")<br />       (princ)<br />     ) ;_ end of progn<br /> ) ;_ end of if<br /> ) ;_ end of defun<br /> <br /> (defun work-whith-all-hatch<br />       (what / adoc *error* poly _loc-delete-or-move-items)<br /> ;;; what - nil - delete<br /> ;;;      - string - layer to move<br /> (defun *error* (msg)<br />    (setvar "MODEMACRO" "")<br />    (princ msg)<br />    (vla-regen aDOC acactiveviewport)<br />    (bg:progress-clear)<br />    (bg:layer-status-restore)<br />    (vla-endundomark aDOC)<br />    (princ)<br /> ) ;_ end of defun<br /> (defun _loc-delete-or-move-items (Blk)<br />    (if (= (vla-get-isxref Blk) :vlax-false)<br />      (progn<br />        (if (> (vla-get-count Blk) 100)<br />          (bg:progress-init<br />            (strcat (vla-get-name Blk) " :")<br />            (vla-get-count Blk)<br />          ) ;_ end of bg:progress-init<br />          (progn<br />            (setvar "MODEMACRO" (vla-get-name Blk))<br />          ) ;_ end of progn<br />        ) ;_ end of if<br />        (vlax-for Obj Blk<br />          (if (= (vla-get-objectname Obj) "AcDbHatch")<br />            (progn<br />              (if (and what (eq (type what) 'STR))<br />                (vl-catch-all-apply 'vla-put-layer (list Obj what))<br />                (vl-catch-all-apply 'vla-delete (list Obj))<br />              ) ;_ end of if<br />            ) ;_ end of progn<br />          ) ;_ end of if<br />        ) ;_ end of vlax-for<br />        (bg:progress-clear)<br />      ) ;_ end of progn<br />    ) ;_ end of if<br /> ) ;_ end of defun<br /> (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))<br /> (vla-startundomark aDOC)<br /> (if (and (eq (type what) 'STR)<br />           (not (tblobjname "LAYER" what))<br />      ) ;_ end of and<br />    (vla-add (vla-get-layers aDOC) what)<br /> ) ;_ end of if<br /> (bg:layer-status-save)<br /> (vlax-for Blk (vla-get-blocks aDOC)<br />    (_loc-delete-or-move-items Blk)<br /> ) ;_ end of vlax-for<br /> (bg:layer-status-restore)<br /> (vla-endundomark aDOC)<br /> (vla-regen aDOC acactiveviewport)<br /> (princ)<br /> ) ;_ end of defun<br /> (defun work-whith-selected-hatch<br />       (what assocpoly / adoc *error* ss lst poly _loc-delete-items)<br /> ;;; what - nil - delete<br /> ;;;      - string - layer to move<br /> ;;; assocpoly - t - move associated poly<br /> ;;;            nil - not<br /> (defun *error* (msg)<br />    (setvar "MODEMACRO" "")<br />    (princ msg)<br />    (vla-regen aDOC acactiveviewport)<br />    (bg:progress-clear)<br />    (bg:layer-status-restore)<br />    (vla-endundomark aDOC)<br />    (princ)<br /> ) ;_ end of defun<br /> (defun _loc-delete-items (Blk)<br />    (if (= (vla-get-isxref Blk) :vlax-false)<br />      (progn<br />        (setq count 0)<br />        (if (> (vla-get-count Blk) 100)<br />          (bg:progress-init<br />            (strcat (vla-get-name Blk) " :")<br />            (vla-get-count Blk)<br />          ) ;_ end of bg:progress-init<br />          (progn<br />            (setvar "MODEMACRO" (vla-get-name Blk))<br />          ) ;_ end of progn<br />        ) ;_ end of if<br />        (vlax-for Obj Blk<br />          (if (= (vla-get-objectname Obj) "AcDbHatch")<br />            (progn<br /> ;;; >>>>> Associated entities begin<br />              (if assocpoly<br />              (setq poly<br />                         (mapcar 'cdr<br />                                 (vl-remove-if-not<br />                                   '(lambda (x) (= (car x) 330))<br />                                   (entget (vlax-vla-object->ename Obj))<br />                                 ) ;_ end of vl-remove-if-not<br />                         ) ;_ end of mapcar<br />                    poly (vl-remove-if-not<br />                           '(lambda (x)<br />                              (wcmatch (cdr (assoc 0 (entget x)))<br />                                       "*LINE,CIRCLE,ELLIPSE"<br />                              ) ;_ end of wcmatch<br />                            ) ;_ end of lambda<br />                           poly<br />                         ) ;_ end of vl-remove-if-not<br />              ) ;_ end of setq<br />              (setq poly nil)  <br />                )<br /> ;;; <<<<<< Associated entities end<br />              (if (and what (eq (type what) 'STR))<br />                (mapcar<br />                  '(lambda (x)<br />                     (vl-catch-all-apply 'vla-put-layer (list x what))<br />                   ) ;_ end of lambda<br />                  (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))<br />                ) ;_ end of mapcar<br />                (mapcar '(lambda (x)<br />                           (vl-catch-all-apply 'vla-delete (list x))<br />                         ) ;_ end of lambda<br />                        (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))<br />                ) ;_ end of mapcar<br />              ) ;_ end of if<br />            ) ;_ end of progn<br />          ) ;_ end of if<br />        ) ;_ end of vlax-for<br />        (bg:progress-clear)<br />      ) ;_ end of progn<br />    ) ;_ end of if<br /> ) ;_ end of defun<br /> (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))<br /> (vla-startundomark aDOC)<br /> (if (and (eq (type what) 'STR)<br />           (not (tblobjname "LAYER" what))<br />      ) ;_ end of and<br />    (vla-add (vla-get-layers aDOC) what)<br /> ) ;_ end of if<br /> (if (and<br />        (setq ss (ssget "_:L" '((0 . "HATCH,INSERT"))))<br />        (setq lst (mapcar 'vlax-ename->vla-object (pickset-to-list ss)))<br />      ) ;_ end of and<br />    (progn<br />      (bg:layer-status-save)<br />      (foreach obj lst<br />        (cond<br />          ((= (vla-get-objectname Obj) "AcDbHatch")<br />          (if  assocpoly<br />           (setq poly<br />                      (mapcar 'cdr<br />                              (vl-remove-if-not<br />                                '(lambda (x) (= (car x) 330))<br />                                (entget (vlax-vla-object->ename Obj))<br />                              ) ;_ end of vl-remove-if-not<br />                      ) ;_ end of mapcar<br />                 poly (vl-remove-if-not<br />                        '(lambda (x)<br />                           (wcmatch (cdr (assoc 0 (entget x)))<br />                                    "*LINE,CIRCLE,ELLIPSE"<br />                           ) ;_ end of wcmatch<br />                         ) ;_ end of lambda<br />                        poly<br />                      ) ;_ end of vl-remove-if-not<br />           ) ;_ end of setq<br />           (setq poly nil)<br />           )<br />           (if (and what (eq (type what) 'STR))<br />             (mapcar '(lambda (x)<br />                        (vl-catch-all-apply 'vla-put-layer (list x what))<br />                      ) ;_ end of lambda<br />                      (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))<br />             ) ;_ end of mapcar<br />             (mapcar<br />               '(lambda (x) (vl-catch-all-apply 'vla-delete (list x)))<br />               (cons Obj (mapcar 'vlax-ename->vla-object poly))<br />             ) ;_ end of mapcar<br />           )<br />          )<br />          ((and<br />             (= (vla-get-objectname Obj) "AcDbBlockReference")<br />             (= (vla-get-isxref<br />                  (setq Blk (vla-item (vla-get-blocks aDOC)<br />                                      (vla-get-effectivename Obj)<br />                            ) ;_ end of vla-item<br />                  ) ;_ end of setq<br />                ) ;_ end of vla-get-IsXref<br />                :vlax-false<br />             ) ;_ end of =<br />           ) ;_ end of and<br />           (_loc-delete-items Blk)<br />          )<br />          (t nil)<br />        ) ;_ end of cond<br />      ) ;_ end of foreach<br />      (bg:layer-status-restore)<br />    ) ;_ end of progn<br /> ) ;_ end of if<br /> (vla-endundomark aDOC)<br /> (vla-regen aDOC acactiveviewport)<br /> (princ)<br /> ) ;_ end of defun<br /> (defun bg:layer-status-restore ()<br /> (foreach item *BG_LAYER_LST*<br />    (if (not (vlax-erased-p (car item)))<br />      (vl-catch-all-apply<br />        '(lambda ()<br />           (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))<br />           (vla-put-freeze<br />             (car item)<br />             (cdr (assoc "freeze" (cdr item)))<br />           ) ;_ end of vla-put-freeze<br />         ) ;_ end of lambda<br />      ) ;_ end of vl-catch-all-apply<br />    ) ;_ end of if<br /> ) ;_ end of foreach<br /> (setq *BG_LAYER_LST* nil)<br /> ) ;_ end of defun<br /> <br /> (defun bg:layer-status-save ()<br /> (setq *BG_LAYER_LST* nil)<br /> (vlax-for item (vla-get-layers<br />                   (vla-get-activedocument (vlax-get-acad-object))<br />                 ) ;_ end of vla-get-layers<br />    (setq *BG_LAYER_LST*<br />           (cons (list item<br />                       (cons "freeze" (vla-get-freeze item))<br />                       (cons "lock" (vla-get-lock item))<br />                 ) ;_ end of cons<br />                 *BG_LAYER_LST*<br />           ) ;_ end of cons<br />    ) ;_ end of setq<br />    (vla-put-lock item :vlax-false)<br />    (if (= (vla-get-freeze item) :vlax-true)<br />      (vl-catch-all-apply<br />        '(lambda () (vla-put-freeze item :vlax-false))<br />      ) ;_ end of vl-catch-all-apply<br />    ) ;_ end of if<br /> ) ;_ end of vlax-for<br /> ) ;_ end of defun<br /> (defun bg:progress-init (msg maxlen)<br /> ;;; msg - niiauaiea eee ionoay no?iea<br /> ;;; maxlen - iaeneiaeuiia eiee?anoai<br /> (setq *BG:PROGRESS:OM* (getvar "MODEMACRO"))<br /> (setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))<br /> (setq *BG:PROGRESS:MAXLEN* maxlen)<br /> (setq *BG:PROGRESS:LPS* '-1)<br /> (princ)<br /> ) ;_ end of defun<br /> (defun bg:progress (currvalue / persent str1 count)<br /> (if *BG:PROGRESS:MAXLEN*<br />    (progn<br />      (setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))<br /> ;;;Ea?aua 5 %<br />      (setq count (fix (* persent 0.2)))<br />      (setq str1 "")<br />      (if (/= count *BG:PROGRESS:LPS*)<br />        (progn<br />          ;;(setq str1 "")<br />          (repeat persent (setq str1 (strcat str1 "|")))<br />        ) ;_ end of progn<br />      ) ;_ end of if<br /> ;;; currvalue - oaeouaa cia?aiea<br />      (setvar "MODEMACRO"<br />              (strcat (vl-princ-to-string *BG:PROGRESS:MSG*)<br />                      " "<br />                      (itoa persent)<br />                      " % "<br />                      str1<br />              ) ;_ end of strcat<br />      ) ;_ end of setvar<br />      (setq *BG:PROGRESS:LPS* persent)<br />    ) ;_ end of progn<br /> ) ;_ end of if<br /> ) ;_ end of defun<br /> <br /> (defun bg:progress-clear ()<br /> (setq *BG:PROGRESS:MSG* nil)<br /> (setq *BG:PROGRESS:MAXLEN* nil)<br /> (setq *BG:PROGRESS:LPS* nil)<br /> (setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))<br /> ;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)<br /> (princ)<br /> ) ;_ end of defun<br /> (defun mydcl (zagl info-list / fl ret dcl_id msg)<br /> (vl-load-com)<br /> (if (null zagl)<br />    (setq zagl "Select")<br /> ) ;_ end if<br /> (setq fl (vl-filename-mktemp "mip" nil ".dcl"))<br /> (setq ret (open fl "w"))<br /> (mapcar '(lambda (x) (write-line x ret))<br />          (list "mip_msg : dialog { "<br />                (strcat "label=\"" zagl "\";")<br />                " :list_box {"<br />                "alignment=top ;"<br />                "multiple_select = true ;"<br />                "width=31 ;"<br />                (if (> (length info-list) 26)<br />                  "height= 26 ;"<br />                  (strcat "height= " (itoa (+ 3 (length info-list))) ";")<br />                ) ;_ end of if<br />                "is_tab_stop = false ;"<br />                "key = \"info\";}"<br />                "ok_cancel;}"<br />          ) ;_ end of list<br /> ) ;_ end of mapcar<br /> (setq ret (close ret))<br /> (if (and (null (minusp (setq dcl_id (load_dialog fl))))<br />           (new_dialog "mip_msg" dcl_id)<br />      ) ;_ end and<br />    (progn (start_list "info")<br />           (mapcar 'add_list info-list)<br />           (end_list)<br />           (set_tile "info" "0")<br />           (setq ret "0")<br />           (action_tile "info" "(setq ret $value)")<br />           (action_tile "cancel" "(done_dialog 0)")<br />           (action_tile "accept" " (done_dialog 1)")<br />           (if (zerop (start_dialog))<br />             (setq ret nil)<br />             (setq<br />               ret (mapcar (function (lambda (num) (nth num info-list)))<br />                           (read (strcat "(" ret ")"))<br />                   ) ;_ end mapcar<br />             ) ;_ end setq<br />           ) ;_ end if<br />           (unload_dialog dcl_id)<br />    ) ;_ end of progn<br /> ) ;_ end of if<br /> (vl-file-delete fl)<br /> ret<br /> ) ;_ end of defun<br /> (defun tablelist (s / d r)<br /> (while (setq d (tblnext s (null d)))<br />    (setq r (cons (cdr (assoc 2 d)) r))<br /> ) ;_while<br /> ) ;_defun<br /> (defun pickset-to-list (value / lst item)<br /> (repeat (setq item (sslength value)) ;_ end setq<br />    (setq lst (cons (ssname value (setq item (1- item))) lst))<br /> ) ;_ end repeat<br /> lst<br /> ) ;_ end of defun<br /> <br /> (defun msg-yes-no ( title message / WScript ret)<br /> (setq WScript (vlax-get-or-create-object "WScript.Shell"))<br /> (setq ret (vlax-invoke-method WScript "Popup" message "0" title (+ 4 48)))<br /> (if WScript (vlax-release-object WScript))<br /> (= ret 6)  <br /> )<br /> (princ<br /> "\nType HatchDelALL, HatchDelSEL, Hatch2LayALL, Hatch2LaySel in command line"<br /> ) ;_ end of princ<br /> (princ)<br /> <br />