;;; ===================================================================================;;
;;; BGTOOLS (Background tools) v.3.1 Copyright © 2009-2016 ;;
;;; Idea conception by: Vladimir Svet (VOVA from dwg.ru) ;;
;;; Programmation by: Vladimir Azarko (VVA from dwg.ru) ;;
;;; special thanks: ֿ¸ענ ֻמסךףעמג (Alaspher),LEE MAC,theswamp.org,dwg.ru,cadtutor.net ;;
;;; ;;
;;; Published ;;
;;; http://forum.dwg.ru/showthread.php?p=735810 ;;
;;; ;;
;;; ===================================================================================;;
;;; ;;
;;; THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY ;;
;;; MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR ;;
;;; PARTS OF IT ABSOLUTELY FREE. ;;
;;; ;;
;;; THIS PROGRAM PROVIDES 'AS IS' WITH ALL FAULTS AND SPECIFICALLY ;;
;;; DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS ;;
;;; FOR A PARTICULAR USE. ;;
;;; ;;
;;; ===================================================================================;;
;;; ;;
;;;=============================================================================================================;;
;;; Command(s) to call EN ;;
;;;=============================================================================================================;;
;;; ;;
;;;BGLAYDEL - delete frozen and off layers with objects
;;;BG1BLEXP - Explode blocks consisting of one element (it is possible other block)
;;;BGBLEXP - Explode the block and all blocks entering into it, transforming visible attributes in the text
;;;BGBLEXP1 - Explode blocks of 1st level, transforming visible attributes in the text
;;;BGBLDYNEXP1 - Explode dynamic blocks of 1st level, transforming visible attributes in the text
;;;BGBLEXP1NOATT -Explode blocks of 1st level which do not have visible attributes
;;;BGBLXCLIP - show xclip blocks
;;;BGBLDYN2A - Convert Dynamic Blocks to Anonymous blocks
;;;BGBLDYN2S - Convert Dynamic Blocks to Static blocks
;;;BGBLALLDYN2A - Conver ALL Dynamic Blocks to Anonymous
;;;BGBLALLDYN2S - Conver ALL Dynamic Blocks to Static
;;;BGBLXCLIPEXP - explode clipped block
;;;BGCB - copy a single block reference in the working drawing
;;;BGRB - rename a single block reference in the working drawing
;;;M2U - Convert MINSERT to Unnamed block
;;;M2B - Convert MINSERT to block
;;;U2B - Convert UNNAMED to block
;;;U2BM - Convert UNNAMED to block multiple selection
;;;UX - Explode UNNAMED block
;;;=======================================
;;;BGRGB2ACI - Changes color from RGB to the corresponding Index Color (ACI)
;;;BGAll2RGB - Converts the ACI colors of all entities to the RGB TrueColor equivalent
;;;BGCOLOR - Set a selected color to all objects (WITHOUT XREF)
;;;BGCOLORXREF - Changes color selected XREF ( ONLY ON A CURRENT SESSION )
;;;BGResetXRef -Resets properties of all layers dependent on the selected XREF(s) to those set in the source drawing file(s).
;;;BGBLCC - Changes color of the chosen blocks
;;;BGENCC - Changes color of the chosen element of the block
;;;BGCATT - Changes color of attributes of the chosen blocks
;;;BGCBL2 - Changes color in blocks 2 and more levels (the nested blocks)
;;;BGBLFIX - fix (normalize) blocks
;;;BGCFT - Convert field to text
;;;BGCFTSEL - Convert field to text in selected objects
;;;BGHATCHDEL - Remove hatch
;;; ;;
;;;=============================================================================================================;;
;;; Command(s) to call RUS ;;
;;;=============================================================================================================;;
;;; ;;
;;;BGLAYDEL - ׃האכוםטו גךכ‏קוםםץ ט חאלמנמזוםםץ סכמוג ס ןנטלטעטגאלט
;;;BG1BLEXP - ֲחנגאוע בכמךט, סמסעמשטו טח מהםמדמ ןנטלטעטגא (גמחלמזםמ הנףדמדמ בכמךא)
;;;BGBLEXP - ֲחנגאוע בכמך ט גסו בכמךט, גץמהשטו ג םודמ, ןנוגנאשא גטהטלו אענטבףע ג עוךסע
;;;BGBLEXP1 - ֲחנגאוע בכמךט 1-דמ ףנמגם, ןנוגנאשא גטהטלו אענטבףע ג עוךסע
;;;BGBLDYNEXP1 - ֲחנגאוע הטםאלטקוסךטו בכמךט 1-דמ ףנמגם, ןנוגנאשא גטהטלו אענטבףע ג עוךסע
;;;BGBLEXP1NOATT - ֲחנגאוע בכמךט 1-דמ ףנמגם, ף ךמעמנץ םוע גטהטלץ אענטבףעמג
;;;BGBLXCLIP - ֿמךאחגאוע ןמהנוחאםםו בכמךט
;;;BGBLDYN2A - ֿנומבנאחמגגאוע הטםאלטקוסךטו בכמךט ג אםמםטלםו
;;;BGBLDYN2S - ֿנומבנאחמגגאוע הטםאלטקוסךטו בכמךט ג סעאעטקוסךטו
;;;BGBLALLDYN2A - ֿנומבנאחמגגאוע ֲֵׁ הטםאלטקוסךטו בכמךט ג אםמםטלםו
;;;BGBLALLDYN2S - ֿנומבנאחמגגאוע ֲֵׁ הטםאלטקוסךטו בכמךט ג סעאעטקוסךטו
;;;BGBLXCLIPEXP - גחמנגאע ןמהנוחאםםי בכמך
;;;BGCB - ךמןטנףוע מהםמ טח גץמזהוםטי בכמךא ג בכמך ס םמגל טלוםול
;;;BGRB - ןונוטלוםמגגאוע מהםמ טח גץמזהוםטי בכמךא ג בכמך ס םמגל טלוםול
;;;M2U - ֿנומבנאחמגאע MINSERT ג Unnamed בכמך
;;;M2B - ֿנומבנאחמגאע MINSERT ג בכמך
;;;U2B - ֿנומבנאחמגאע UNNAMED ג בכמך
;;;U2BM - ֿנומבנאחמגאע UNNAMED ג בכמך לםמזוסעגוםםי גבמנ
;;;UX - ֲחמנגאע UNNAMED בכמך
;;;=======================================
;;;BGRGB2ACI - ָחלוםוע צגוע ס RGB םא ACI
;;;BGAll2RGB - ָחלוםוע ACI צגוע ג ודמ RGB ‎ךגטגאכוםע
;;;BGCOLOR - ַאהאוע גבנאםםי צגוע גסול מבתוךעאל
;;;BGCOLORXREF - ּוםוע צגוע גבנאםםץ גםורםטץ סכמך (עמכךמ ג עוךףרול סואםסו)
;;;BGResetXRef -ׁבנמס םאסענמוך סכמוג גבנאםםץ גםורםטץ ססכמך םא ףסעאםמגכוםםו ג
;;;טסץמהםמל פאיכו
;;;BGBLCC - ָחלוםוע צגוע גבנאםםץ בכמךמג
;;;BGENCC - ָחלוםוע צגוע גבנאםםמדמ ‎כולוםעא בכמךא
;;;BGCATT - ָחלוםוע צגוע אענטבףעמג גבנאםםץ בכמךמג
;;;BGCBL2 - ָחלוםוע צגוע ג בכמךאץ 2 ט במכוו ףנמגם (גכמזוםםץ בכמךאץ)
;;;BGBLFIX - ֽמנלאכטחאצט בכמךמג
;;;BGCFT - ֺמםגונעטנףוע גסו ןמכ ג מבקםי עוךסע
;;;BGCFTSEL - ךמםגונעטנמגאםטו ןמכוי ג מבקםי עוךסע ג גבנאםםץ ןנטלטעטגאץ
;;;BGHATCHDEL - ׃האכוםטו רענטץמגךט

;;;=============================================================================================================;;
;;; ;;
;;; HISTORY ;;
;;;=============================================================================================================;;
;;; EN ;;
;;;=============================================================================================================;;
;;; ;;
;;; 1.0 - fixed burst - the inheritance of the line type byblock, displaying hidden attributes, and inheritance type of line unit
;;; Added processing Burst LineWeight
;;; 1.1 unit change in color in the presence of attributes (cm;;; Change VVA 12.09.2008)
;;; ...
;;: 1.4 Handling multiline styles
;;; 1.11 ChangeAllObjectsColor - Handling size, leader and mtext with an explicit color.
;;; BGBLEXP - processing appearances dynamic blocks (if the visibility attributes are included)
;;; BG1BLEXP - Obabatyvayutsya units consisting of one element and
;;; - Name of the block A$C*
;;; - Or any other name and this one element of another block
;;; 1.12 - Do not remove the blocks, located on the off / frozen layer
;;; And having at least one primitive layer turned on, other than "0"
;;; 2.0 - BGBLEXP - Fixed a bug with the list
;;; 2.1 - processing blocks external links ChangeXrefAllObjectsColor
;;; 2.2 - Add command BGCFT
;;; 2.3 - add BGCOLORXREF and BGRGB2ACI
;;; 2.4 - Processing of multi-attribute
;;; 2.5 - Added bg:FieldCode ChangeAllObjectsColor ChangeXrefAllObjectsColor - processing of Unicode characters
;;; 2.6 - Adding a BGBLDYN2A BGBLDYN2S
;;; 2.7 - Added handling of pre-selection
;;; 2.8 - Error handling and visibility attributes
;;; 2.9 - Added BGBLDYNEXP1
;;; 2.10 - Convert dynamic blocks bg:DynToStatic. Saving and restoring the values of attributes
;;; 2.11 - Changes in the bg:get-all-atts (processing UNICOD characters in attribute values)
;;; BGHATCHDEL
;;; ChangeAllObjectsColor - change table text and grid color
;;; 2.12 - Counted lineweight to the attributes
;;; 2.13 - Add BG:GET-TEXTSTRING functions
;;; 2.14 - Add BGAll2RGB and Change ClearFieldInAllObjects look http://forum.dwg.ru/showthread.php?t=76285 post #6
;;; 2.15 - minor change in BGAll2RGB. Add BGCB and BGRB
;;;;2.16 - BGCBL2 now work with ACI and RGB color
;;;;2.17 - BGBLCC now work with ACI and RGB color and other minor change
;;; 2.18 - add command BGBLXCLIPEXP
;;; 2.19 - BGBLFIX add lock layer
;;; 2.20 - BGBLFIX fix bugs
;;; 2.21 - BGBLENCC fix bugs.
;;; 2.22 - Add Scale Uniformly and Allow Expoding options
;;; 2.23 - Fix BGCB BGRB command
;;; 2.24 - Edit UX command
;;; 2.25 - Fix BGBLCC ט BGCBL2 command. Add BGCFTSEL
;;; 2.26 - Fix BGCFT command. Add BGBLALLDYN2A and BGBLALLDYN2S
;;; 2.27 - in command U2B, UX added processing blocks named *E
;;; 2.28 Fixed minor bugs in BGCFT command and function bg:DynToStatic
;;; 2.29 Fixed minor bugs in function ClearFieldInThisObject
;;; 2.30 Fixed minor bugs in function ClearFieldInThisObject
;;; http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/vla-get-textstring-u-symbols/td-p/4365165
;;; 2.31 BGCFT clear field in dimention now
;;; (http://forum.dwg.ru/showthread.php?p=1335110#post1335110)
;;; 2.32 minor change in bg:get-TextString (http://forum.dwg.ru/showpost.php?p=1386990&postcount=235) mark ; VVA 2015-03-27
;;; 2.33 minor change in bg:get-TextString (http://forum.dwg.ru/showpost.php?p=1409930&postcount=252) mark ; VVA 2015-05-23
;;; 2.34 BGBLFIX now change named plot style
;;; 2.35 BGBLEXP minor change
;;; 2.36 UX minor change http://forum.dwg.ru/showthread.php?p=1421560#post1421560
;;; 2.37 BGCFT fix bug with lock sell/ Marked as ;_Add VVA 2015-07-08
;;; 2.38 BGLAYDEL fix bug with restore layer setting
;;; 2.40 minor change in function bg:FieldCode. Add function bg:GetObjectIDString mark VVA 2015-12-07
;;; 2.41 minor change in function ClearFieldInThisObject. Mark VVA 2016-01-04
;;; 3.0 BGCOLBL
;;; 3.1 BGBLEXP - save field in attrib

;;;=============================================================================================================;;
;;; RUS ;;
;;;=============================================================================================================;;
;;; 1.0 - טסןנאגכום מרטבךט burst - ןנט םאסכוהמגאםטט עטןא כטםטט ןמבכמךף, ןמךאח סךנעץ אענטבףעמג ט םאסכוהמגאםט עטןא כטםטט בכמךא
;;; וסכט ג בכמך ןנטלטעטג גץמהטכ םו םא 0 סכמו, עטן כטםטט ןמבכמךף.
;;; המבאגכוםא מבנאבמעךא Burst LineWeight
;;; 1.1 טחלוםוםטו צגועא בכמךא ןנט םאכטקטט אענטבףעמג (סל ;;; Change VVA 12.09.2008)
;;; ...
;;; 1.4 ־בנאבמעךא סעטכוי לףכעטכטםטי
;;; 1.11 ChangeAllObjectsColor - ־בנאבמעךא נאחלונמג, leader ט mtext ס גםל חאהאםטול צגועא.
;;; BGBLEXP - מבנאבמעךא גטהטלמסעוי הטםאלטקוסךטץ בכמךמג (וסכט ג גטהטלמסעט גךכ‏קום אענטבףע)
;;; BG1BLEXP - ־באבאעגא‏עס בכמךט, סמסעמשטו טח מהםמדמ ‎כולוםעא ט
;;; - טל בכמךא A$C*
;;; - טכט כ‏במו הנףדמו טל ט ‎עמע מהטם ‎כולוםע הנףדמי בכמך
;;; 1.12 - ֽו ףהאכוע בכמךט, נאסןמכמזוםםו םא גךכ‏קוםםמל/ חאלמנמזוםםמל סכמו
;;; ט טלו‏שטו ץמע ב 1 ןנטלטעטג םא גךכ‏קוםםמל סכמו, מעכטקםמל מע "0"
;;; 2.0 - BGBLEXP - טסןנאגכוםא מרטבךא סמ סןטסךמל
;;; 2.1 - מבנאבמעךא בכמךמג גםורםטץ ססכמך ChangeXrefAllObjectsColor
;;; 2.2 - ךמלאםהא BGCFT
;;; 2.3 - add BGCOLORXREF and BGRGB2ACI
;;; 2.4 - ־בנאבמעךא לםמדמסענמקםץ אענטבףעמג
;;; 2.5 - ִמבאגכוםםא bg:FieldCode ChangeAllObjectsColor ChangeXrefAllObjectsColor - מבנאבמעךא Unicode סטלגמכמג
;;; 2.6 - ִמבאגכוםם ךמלאםה BGBLDYN2A BGBLDYN2S
;;; 2.7 - ִמבאגכוםא מבנאבמעךא ןנוהגאנטעוכםמדמ גבמנא
;;; 2.8 - ־רטבךט ס מבנאבמעךמי אענטבףעמג ט visibility
;;; 2.9 - ִמבאגכוםא BGBLDYNEXP1
;;; 2.10 - ֺמםגונעאצט הטםאלטקוסךטץ בכמךמג bg:DynToStatic. ׁמץנאםוםטו ט גמססעאםמגכוםטו חםאקוםטי אענטבףעמג
;;; 2.11 - ָחלוםוםט ג bg:get-all-atts (מבנאבמעךא UNICOD סטלגמכמג ג חםאקוםטץ אענטבףעמג)
;;; BGHATCHDEL
;;; ChangeAllObjectsColor - change table text and grid color
;;; 2.12 - ׃קעום lineweight הכ אענטבףעמג
;;; 2.13 - ִמבאגכוםא פףםךצט BG:GET-TEXTSTRING (ךאך חאלוםא vla-get-textstring. ׂ.ך. םוגונםמ גמחגנאשאוע סענמךף ןנט םאכטקטט ‏םטךמה סטלגמכמג)
;;; 2.14 - ִמבאגכוםא ךמלאםהא BGAll2RGB ָחלוםוםא ClearFieldInAllObjects סל http://forum.dwg.ru/showthread.php?t=76285 post #6
;;; 2.15 - ֽובמכרטו טחלוםוםט ג BGAll2RGB. המבאגכום BGCB ט BGRB
;;;; 2.16 - BGCBL2 עוןונ נאבמעאוע ס RGB ט ACI צגועאלט
;;;; 2.17 - BGBLCC עוןונ נאבמעאוע ס RGB ט ACI צגועאלט + לוכךטו טחלוםוםט
;;;; 2.18 - ׃קעוםמ ןנוהכמזוםטו http://forum.dwg.ru/showpost.php?p=949149&postcount=102
;;;; ִמבאגכוםא ךמלאםהא BGBLXCLIPEXP
;;;; 2.19 - ֺמלאםהא BGBLFIX. ִמבאגכוםא מןצט טדםמנטנמגאםט סכמוג
;;;; 2.20 - ֺמלאםהא BGBLFIX. ָסןנאכום באד ס אענטבףעאלט
;;; 2.22 - ִמבאגכום מןצטט ־הטםאךמגו לאסרעאב ט ׀אחנורטע נאסקכוםוםטו
;;; 2.23 - ָסןנאגכום מרטבךט ג ךמלאםהאץ BGRB ט BGCGB
;;; 2.24 - ־ענוהאךעטנמגאםא ךמלאםהא UX (גכמזוםםמסע אםמםטלםץ בכמךמג)
;;; 2.25 - http://forum.dwg.ru/showthread.php?p=1024096#post1024096
;;; 2.25 - Fix BGBLCC ט BGCBL2 command http://forum.dwg.ru/showthread.php?p=1088187#post1088187
;;; Add BGCFTSEL http://forum.dwg.ru/showthread.php?t=20190&page=2
;;; 2.26 - BGCFT - המבאגכוםא מבנאבמעךא פמנלאעא עוךסעא ג עאבכטצו. ִמבאגכום ךמלאםה BGBLALLDYN2A ט BGBLALLDYN2S
;;; 2.27 - ג ךמללאםהאץ U2B ,UX המבאגכוםא מבנאבמעךא בכמךמג ס טלוםול *E
;;; 2.28 - BGCFT - טסןנאגכוםא מרטבךא + טחלוםוםט ג function bg:DynToStatic
;;; 2.29 - ָסןנאגכום םוהמקוע ClearFieldInThisObject
;;; 2.30 Fixed minor bugs in function ClearFieldInThisObject
;;; http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/vla-get-textstring-u-symbols/td-p/4365165
;;; 2.31 BGCFT המבאגכוםא מקטסעךא ןמכוי ג נאחלונאץ
;;; (http://forum.dwg.ru/showthread.php?p=1335110#post1335110)
;;; 2.32 טחלוםוםט ג bg:get-TextString (http://forum.dwg.ru/showpost.php?p=1386990&postcount=235) ןמלוקוםמ ; 2015-03-27
;;; ןמכ ג לףכעטגםמסךאץ
;;; 2.33 טחלוםוםט ג bg:get-TextString (http://forum.dwg.ru/showpost.php?p=1386990&postcount=252) ןמלוקוםמ ; 2015-05-23
;;; 2.34 BGBLFIX מבנאבמעךא טלוםמגאםםץ סעטכוי ןוקאעט
;;; 2.35 BGBLEXP טחלוםוםט VVA 2015-06-15
;;; 2.36 טחלוםוםט ג ךמלאםהו UX http://forum.dwg.ru/showthread.php?p=1421560#post1421560
;;; 2.37 BGCFT טסןנאגכוםא מרטבךא ןנט מבנאבמעךו חאבכמךטנמגאםםץ קווך עאבכטצ ךמללוםעאנטט ג עוךסעו ;_Add VVA 2015-07-08
;;; 2.38 BGLAYDEL טסןנאגכוםא מרטבךא ס גמסעאםמגכוםטול סכמוג
;;; 2.40 ָחלוםוםט ג פ-צטט bg:FieldCode. ִמבאגכוםא פ-צט bg:GetObjectIDString mark VVA 2015-12-07
;;; 2.41 ָחלוםוםט ג פ-צטט ClearFieldInThisObject. ־בנאבמעךא חםאקוםטי נאחלונמג םאה ט ןמה נאחלונםמי כטםטוי
;;; Mark VVA 2016-01-04. ֿמהנמבםוו סל. http://forum.dwg.ru/showthread.php?p=1489832#post1489832
;;; 3.0 BGCOLBL
;;; 3.1 BGBLEXP - סמץנאםוםטו ןמכוי ג אענטבףעאץ

(vl-load-com)

(defun bg:purge-layer-filter ()
;;;Purge layer filter
;;; ׃האכוםטו פטמכענמג סכמוג
(mapcar '(lambda (dictionary)
(vl-catch-all-apply
'(lambda ()
(vla-remove
(vla-getextensiondictionary
(vla-get-layers
(vla-get-activedocument
(vlax-get-acad-object)
) ;_ end of vla-Get-ActiveDocument
) ;_ end of vla-Get-Layers
) ;_ end of vla-GetExtensionDictionary
dictionary
) ;_ end of vla-Remove
) ;_ end of lambda
) ;_ end of vl-Catch-All-Apply
) ;_ end of lambda
'("ACLYDICTIONARY" "ACAD_LAYERFILTERS" "ACAD_LAYERSTATES")
) ;_ end of mapcar
) ;_ end of defun
(defun bg:purge-groups ( / grpList index grp)
;; װ-צט bg:purge-groups
;; ׃האכוע מןטסאםטו גסוץ דנףןן
;; ְנדףלוםע [ׂטן]:
;; ֵֽׂ
;; ֲמחגנאשאוע: Nil
;;;;;; (setq grpList (dictsearch (namedobjdict) "ACAD_GROUP"))
;;;;;; (setq index 1)
;;;;;; (while (setq grp (nth index grplist))
;;;;;; (if (= (car grp) 3)
;;;;;; (entdel (cdr (nth (+ index 1) grplist)))
;;;;;; )
;;;;;; (setq index (+ 1 index))
;;;;;; )
;;;;;; (princ)
(vlax-for grp (vla-item (vla-get-Dictionaries (vla-get-activedocument (vlax-get-acad-object))) "ACAD_GROUP")
(vl-catch-all-apply 'vla-delete (list grp))
)
)
(defun bg:purge-AllPageSetups (/ pc)
;;;׃האכוםטו סמץנאםוםםץ page setups
(vlax-for pc (vla-get-plotconfigurations (vla-get-activedocument (vlax-get-acad-object)))
(vla-delete pc)
)
)

(defun bg:purge-apps ( / Blk Obj appid)
;;;׃האכוםטו חאנודוסענטנמגאםםץ ןנטכמזוםטי
;;; (vlax-for Blk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
;;; (if (= (vla-get-isxref Blk) :vlax-false)
;;; (progn
;;; (grtext -1
;;; (strcat "Inspecting objects: "
;;; (vla-get-name Blk)
;;; ) ;_ end of strcat
;;; ) ;_ end of grtext
;;;
;;; (vlax-for Obj Blk (bg:del-XDATA-from-ename Obj nil))
;;; ) ;_ end of progn
;;; ) ;_ end of if
;;; ) ;_ end of vlax-for
(vlax-for appid (vla-get-registeredapplications
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(vl-catch-all-apply 'vla-delete (list appid))
)
)
;;; (vl-catch-all-apply 'bg:purge-DGNLINE nil)
(defun bg:purge-ACADVBA ()(dictremove (namedobjdict) "ACAD_VBA"))
(defun bg:purge-DATALINK ()(dictremove (namedobjdict) "ACAD_DATALINK"))
(defun bg:purge-DGNLINE ()(dictremove (namedobjdict) "ACAD_DGNLINESTYLECOMP"))

(defun bg:purge-all ()
(grtext -1 "Audit ... ")
(vla-auditinfo (vla-get-activedocument (vlax-get-acad-object)) :vlax-true)
(grtext -1 "purge layer filter")
(bg:purge-layer-filter)
(grtext -1 "purge groups")
(bg:purge-groups)
(grtext -1 "purge Page Setups")
(bg:purge-AllPageSetups)
(bg:purge-ACADVBA)
(bg:purge-DATALINK)
(bg:purge-DGNLINE)
(grtext -1 "purge Apps")
(bg:purge-apps)
;;; http://www.theswamp.org/index.php?topic=42110.0
;;; (dictremove (namedobjdict) "ACAD_DGNLINESTYLECOMP")
(repeat 3 (vla-purgeall (vla-get-activedocument (vlax-get-acad-object))))
(command "_.Regenall")
)
(defun bg:progress-init (msg maxlen)
;;; msg - סממבשוםטו טכט ןףסעא סענמךא
;;; maxlen - לאךסטלאכםמו ךמכטקוסעגמ
(BG:PROGRESS-CLEAR)
(if (and acet-ui-progress-init acet-ui-progress-safe acet-ui-progress-done)
(progn
(acet-ui-progress-init msg maxlen); init - interval length
)
(progn
(or *BG:PROGRESS:OM* (setq *BG:PROGRESS:OM* (getvar "MODEMACRO")))
(setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))
(setq *BG:PROGRESS:MAXLEN* maxlen)
(setq *BG:PROGRESS:LPS* '-1)
)
)
(princ)
)
(defun bg:progress ( currvalue / persent str1 count)
(if (and acet-ui-progress-init acet-ui-progress-safe acet-ui-progress-done)
(progn
(acet-ui-progress-safe currvalue)
)
(progn
(if *BG:PROGRESS:MAXLEN*
(progn
(setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))
;;;ֺאזהו 5 %
(setq count (fix(* persent 0.2)))
(setq str1 "")
(if (/= count *BG:PROGRESS:LPS*)
(progn
;;(setq str1 "")
(repeat persent (setq str1 (strcat str1 "|")))
)
)
;;; currvalue - עוךףשוו חםאקוםטו
(setvar "MODEMACRO"
(strcat (vl-princ-to-string *BG:PROGRESS:MSG*)
" "
(itoa persent)
" % "
str1
)
)
(setq *BG:PROGRESS:LPS* persent)
)
)
)
)
(princ)
)

(defun bg:progress-clear ()
(if (and acet-ui-progress-init acet-ui-progress-safe acet-ui-progress-done)
(progn
(acet-ui-progress-done)
)
(progn
(setq *BG:PROGRESS:MSG* nil)
(setq *BG:PROGRESS:MAXLEN* nil)
(setq *BG:PROGRESS:LPS* nil)
(setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))
;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
)
)
(princ)
)
;;;; װףםךצט גגמהטע הטאכמדמגמו מךםמ ִא-ֽוע
;;;;title - חאדמכמגמך
;;;;message - סממבשוםטו
;;;; ֲמחגנאשאוע t - ִא
;;;; nil - ֽוע
;;; ֿנטלונ (bg:MSG-YES-NO "ֿנטגוע" "ֿמיהול ג ךטםמ?")
;;;(defun bg:msg-yes-no ( title message / usri1 ret)
;;;(setq usri1 (getvar "USERI1"))
;;;(SETVAR "USERI1" 0)
;;;(command "_vbastmt"
;;;(strcat "ThisDrawing.SetVariable \"USERI1\", "
;;;"MsgBox \(\""
;;;message
;;;"\","
;;;(itoa vlax-VBYesNo)
;;;",\""
;;;title
;;;"\"\)"
;;;)
;;;)
;;;(setq ret (= (getvar "USERI1") 6))
;;;(SETVAR "USERI1" usri1)
;;;ret
;;;)
(defun mip_MTEXT_Unformat ( Mtext / text Str )
;;;http://www.caduser.ru/forum/index.php?PAGE_NAME=read&FID=44&TID=20992
(setq Text "")
;;; (if (wcmatch (strcase Mtext) "\\PI-#*,\\PT*") ;;_סןטסמך
;;; (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
(while (/= Mtext "")
(cond
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3) Text (strcat Text Str)))
((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
(setq Mtext (substr Mtext 3)))
((wcmatch (strcase (substr Mtext 1 8)) "\\FSYMBOL") ;;;Add VVA remove Symbol
(setq Mtext (substr Mtext (+ 2 (cond ((vl-string-search "}" Mtext))((vl-string-search ";" Mtext)))))))
((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase Mtext) "\\PI-#*,\\PT*") ;;;VVA 2011-01-20
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase (substr mtext 1 4)) "\\PQ[CRJD],\\PTZ") ;;;Add by KPblC
(setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
)
((wcmatch (strcase (substr mtext 1 3)) "\\PX") ;;;אבחאצ ט לוזהףסענמקםי טםעונגאכ \\PX[QITSBA]
(setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
)
((wcmatch (strcase (substr Mtext 1 2)) "\\P")
(if (or
(zerop (strlen Text))
(= " " (substr Text (strlen Text)))
(= " " (substr Mtext 3 1)))
(setq Mtext (substr Mtext 3))
(setq Mtext (substr Mtext 3) Text (strcat Text " "))))
((wcmatch (strcase (substr Mtext 1 2)) "\\S")
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))))

(t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))))
Text)

(defun bg:msg-Popup ( title message flags / WScript ret )
;;; title - text to displayed in title bar
;;; message - message
;;; flags - integer icon+ button See http://msdn2.microsoft.com/en-us/library/x83z1d9f.aspx
;;; intButton = object.Popup(strText,[nSecondsToWait],[strTitle],[nType])
;;; Use (bg:msg-Popup "Test" "2+2=4\nRight?" (+ 4 32 4096))

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;; ֺמה nType ׁףללא ֺםמןךט + ָךמםךט

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;; ֺםמןךט Button
;;;0 - Show OK button.
;;;1 - Show OK and Cancel buttons.
;;;2 - Show Abort, Retry, and Ignore buttons.
;;;3 - Show Yes, No, and Cancel buttons.
;;;4 - Show Yes and No buttons.
;;;5 - Show Retry and Cancel buttons.

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;; ָךמםךט Icon Types
;;;16 - Show "Stop Mark" icon.
;;;32 - Show "Question Mark" icon.
;;;48 - Show "Exclamation Mark" icon.
;;;64 - Show "Information Mark" icon.

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; Other

;;;256 The second button is the default button.
;;;512 The third button is the default button.
;;;4096 The message box is a system modal message box and appears in a topmost window.
;;;524288 The text is right-justified.
;;;1048576 The message and content text display in right-to-left reading order.

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; Return - intButton ֲמחגנאשאולמו חםאקוםטו

;;;1 - OK button
;;;2 - Cancel button
;;;3 - Abort button
;;;4 - Retry button
;;;5 - Ignore button
;;;6 - Yes button
;;;7 - No button

;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(vl-catch-all-apply
(function
(lambda ()
(setq WScript (vlax-create-object "WScript.Shell"))
(setq ret (vlax-invoke-method WScript "popup" message "0" title flags))
)
)
)
(if WScript (vlax-release-object WScript))
ret
)
(defun bg:msg-yes-no ( title message)
;;; title - text to displayed in title bar
;;; message - message
;;; Return T - Yes button NIl - No button
(= (bg:msg-Popup title message (+ 4 48)) 6)
)

;|
* װ-צט str-str-lst
* ׁונגטסםא פ-צט טחגכוקוםט טח סענמךט האםםץ, נאחהוכוםםץ
* ךאךטל כטבמ סטלגמכמל טכט סענמךמי סטלגמכמג
* ֲמחגנאשאוע סןטסמך סענמך
* ְנדףלוםע [Type]:
str - סענמךא הכ נאחבמנא [STRING]
pat - נאחהוכטעוכ [STRING]
* ֿנטלונ חאןףסךא
(setq str "ל;טחףקאול;נוךףנסטט" pat ";")
(setq str "ל — טחףקאול — נוךףנסטט" pat " — ")
(str-str-lst str pat)
* ׳טעאע ןמהנמבםוו http://www.caduser.ru/cgi-bin/f1/board.cgi?t=25113OT
|;
(defun str-str-lst (str pat / i)
(cond ((= str "") nil)
((setq i (vl-string-search pat str))
(cons (substr str 1 i)
(str-str-lst (substr str (+ (strlen pat) 1 i)) pat)
) ;_ cons
)
(t (list str))
) ;_ cond
) ;_ defun

(defun bg:layer-status-restore ()
(foreach item *BG_LAYER_LST*
(if (not (vlax-erased-p (car item)))
(vl-catch-all-apply
'(lambda ()
(vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
(vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
(vla-put-LayerOn (car item) (cdr (assoc "onoff" (cdr item))))
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of if
) ;_ end of foreach
(setq *BG_LAYER_LST* nil)
) ;_ end of defun

(defun bg:layer-status-save ()
(setq *BG_LAYER_LST* nil)
(vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(setq *BG_LAYER_LST* (cons (list item
(cons "freeze" (vla-get-freeze item))
(cons "lock" (vla-get-lock item))
(cons "onoff" (vla-get-LayerOn item))
) ;_ end of cons
*BG_LAYER_LST*
) ;_ end of cons
) ;_ end of setq
(vla-put-lock item :vlax-false)
(if (= (vla-get-freeze item) :vlax-true)
(vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))))
) ;_ end of vlax-for
) ;_ end of defun
(defun bg:get-TextString (ent / elst str)
;;; ent -entity name
;;; return - text string
(setq elst (entget ent))
(if (vlax-property-available-p (vlax-ename->vla-object ent) 'Textstring)
(cond ((= (cdr(assoc 0 elst)) "MULTILEADER")
(if (and
(cdr (assoc 360 elst));_VVA 2015-05-23
(dictsearch (cdr (assoc 360 elst)) "ACAD_FIELD") ;;; (BG:FIELDCODE ent) ;;;VVA 2015-03-27
)
(setq str (vla-get-TextString (vlax-ename->vla-object ent)))
(setq str (cdr(assoc 304 elst)))
)
)
((and ;;; MTEXT ATTRIB ADD VVA 2011-20-27
(member (cdr(assoc 0 elst)) '("ATTRIB"))
(member '(101 . "Embedded Object") elst)
)
(setq str (apply 'strcat (append (bg:massoc 3 elst)(bg:massoc 1 (member '(101 . "Embedded Object") elst)))))
)

((member (cdr(assoc 0 elst)) '("TEXT" "MTEXT" "ATTRIB"))
(setq str (apply 'strcat (append (bg:massoc 3 elst)(bg:massoc 1 elst))))
)
(t (setq str (vla-get-TextString (vlax-ename->vla-object ent))))
)
)
str
)
;| ! ***************************************************************************
;; ! bg:massoc
;; ! ***************************************************************************
;; ! Function : Utility function to get multiple group code
ֲמחגנאשאוע גסו גץמזהוםט ךכ‏קא ג סןטסךו
;; ! Argument : 'key' - The DXF code to check / DXF ךמה
;; ! 'alist' - The List to check / ׁןטסמך
;; ! Returns : The value of the DXF dotted pair, if it exists else returns nil
ַםאקוםטו עמקוקםמי ןאנ, וסכט וסע טכט nil
;; ! ****************************************************************************|;
;;; Utility function to get multiple group code CDRs
(defun bg:massoc (key alist)
;;;lib:massoc mip_lib.lsp
(mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))
(defun bg:FieldCode (ent / foo elst xdict dict field str)
;; credits gile gc:FieldCode
(defun ObjIdxStr (fld / pos)
(setq pos (vl-string-search "ObjIdx " (cdr (assoc 2 fldId)) 0))
(substr fld (1+ pos) (- (vl-string-search ">%" fld pos) pos))
)
(defun foo (field str / pos fldID objID)
(setq pos 0)
(if (setq pos (vl-string-search "\\_FldIdx " str pos))
(while (setq pos (vl-string-search "\\_FldIdx " str pos))
(setq fldId (entget (cdr (assoc 360 field)))
field (vl-remove (assoc 360 field) field))
(setq
str (strcat
(substr str 1 pos)
(if (setq objID (cdr (assoc 331 fldId)))
(vl-string-subst
;;; (strcat "ObjId " (itoa (gc:EnameToObjectId objID))) ;;; VVA 2015-12-07
(strcat "ObjId " (bg:GetObjectIDString objID))
;;; "ObjIdx" ;;; rem VVA 2015-12-07
(ObjIdxStr (cdr (assoc 2 fldId))) ;;; add VVA 2015-12-07
(cdr (assoc 2 fldId))
)
(foo fldId (cdr (assoc 2 fldId)))
)
(substr str (1+ (vl-string-search ">%" str pos)))
)
)
)
str
)
)
;;; ;; gc:EnameToObjectId (gile)
;;; ;; Returns the ObjectID from an ename
;;; ;;
;;; ;; Argument : an ename
;;;
;;; (defun gc:EnameToObjectId (ename)
;;; ;; credits gile
;;; ((lambda (str1)
;;; (hex2dec
;;; (substr (vl-string-right-trim ">" str1) (+ 3 (vl-string-search ":" str1)))
;;; )
;;; )
;;; (vl-princ-to-string ename)
;;; )
;;; )
;;; ;;============================================================;;
;;; ;; hex2dec (gile)
;;; ;; convert an hexadecimal into a decimal (int)
;;; ;;
;;; ;; Argument : un hexadedimal (string)
;;;
;;; (defun hex2dec (s / r l n)
;;; (setq r 0 l (vl-string->list (strcase s)))
;;; (while (setq n (car l))
;;; (setq l (cdr l)
;;; r (+ (* r 16) (- n (if (vla-object ent) 'Textstring)
(cond ((= (cdr(assoc 0 elst)) "MULTILEADER")
(setq str (cdr(assoc 304 elst)))
)
((and ;;; MTEXT ATTRIB ADD VVA 2011-20-27
(member (cdr(assoc 0 elst)) '("ATTRIB"))
(member '(101 . "Embedded Object") elst)
)
(setq str (apply 'strcat (append (bg:massoc 3 elst)(bg:massoc 1 (member '(101 . "Embedded Object") elst)))))
)

((member (cdr(assoc 0 elst)) '("TEXT" "MTEXT" "ATTRIB"))
(setq str (apply 'strcat (append (bg:massoc 3 elst)(bg:massoc 1 elst))))
)
(t (setq str (vla-get-TextString (vlax-ename->vla-object ent))))
)
)
(if (and
(member (cdr (assoc 0 elst)) '("ATTRIB" "MTEXT" "TEXT" "MULTILEADER"))
(setq xdict (cdr (assoc 360 elst)))
(setq dict (dictsearch xdict "ACAD_FIELD"))
(setq field (dictsearch (cdr (assoc -1 dict)) "TEXT"))
)
(setq str (foo field (cdr (assoc 2 field))))
)
str
)
(defun bg:GetObjectIDString ( obj / *util* )
(if (eq (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
(setq *util* (vla-get-Utility (vla-get-ActiveDocument (vlax-get-acad-object))))
(if (vlax-method-applicable-p *util* 'GetObjectIdString)
(vla-GetObjectIdString *util* obj :vlax-false)
(itoa (vla-get-ObjectId obj))
)
)
(defun ChangeAllObjectsColor (Doc Color / txtstr tmp txt count _mtext-color-clean)

(defun _mtext-color-clean ( txtstr / tmp )
(setq txtstr (VL-PRINC-TO-STRING txtstr)
tmp 0
)
(while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))
(setq txtstr
(vl-string-subst
(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")
(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))
txtstr
tmp)
)
(setq tmp (+ tmp 3))
)
txtstr
)
(vlax-for Blk (vla-get-Blocks Doc)
(if (= (vla-get-IsXref Blk) :vlax-false)
(progn
(setq count 0 txt (strcat "Changed " (vla-get-name Blk)))
(grtext -1 txt)
(if (not (wcmatch (vla-get-name Blk) "`*T*,`*D*")) ;_exclude table dimension
(vlax-for Obj Blk
(setq count (1+ count))
(if (zerop(rem count 10))(grtext -1 (strcat txt " : " (itoa count))))
(if (and (vlax-write-enabled-p Obj)
(vlax-property-available-p Obj 'Color)
) ;_ end of and
(vla-put-Color Obj Color)
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
(vlax-property-available-p Obj 'TextString)
) ;_ end of and
(progn
;;; >>>--------- comment VVA 2011-04-28
;;; (setq txtstr
;;; (if (vlax-method-applicable-p Obj 'FieldCode)
;;; (vla-FieldCode Obj)
;;; (vlax-get-property Obj 'TextString))
;;; )
;;; <<>>--------- ADD VVA 2011-04-28
;;; (setq txtstr (bg:FieldCode (vlax-vla-object->ename Obj)))
;;; <<ename Obj))))) ;;;CH VVA 15.09.2011
)
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
(= (vla-get-ObjectName obj) "AcDbBlockReference")
(= (vla-get-HasAttributes obj) :vlax-true)
) ;_ end of and
(foreach att (vlax-safearray->list
(vlax-variant-value (vla-GetAttributes obj))
) ;_ end of vlax-safearray->list
(if (and (vlax-write-enabled-p att)
(vlax-property-available-p att 'Color)
) ;_ end of and
(vla-put-Color att Color)
) ;_ end of if
) ;_ end of foreach
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
(wcmatch (vla-get-Objectname Obj) "*Dimension*,AcDb*Leader")
) ;_ end of and
(progn
(vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))
(vl-catch-all-apply 'vla-put-TextColor (list Obj Color))
(vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))
(if (vlax-property-available-p Obj 'LeaderLineColor)
(progn
(setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."
(substr (getvar "ACADVER") 1 2))))
(vla-put-colorindex tmp Color)
(vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))
)
)
) ;_ end of progn
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
(wcmatch (vla-get-Objectname Obj) "AcDbTable")
) ;_ end of and
(progn
(and (vlax-property-available-p Obj 'RegenerateTableSuppressed)
(vla-put-RegenerateTableSuppressed Obj :vlax-true)
)
(VL-CATCH-ALL-APPLY
'(lambda (col row / i j)
(setq i '-1)
(repeat col
(setq i (1+ i) j '-1)
(repeat row
(setq j (1+ j))
(if (= (vla-GetCellType Obj j i) acTextCell)
(vla-settext obj j i
(_mtext-color-clean
(vla-gettext obj j i)
)
)
)
(vla-SetCellContentColor obj j i (vla-get-truecolor obj))
(vla-SetCellGridColor obj j i (+ acBottomMask acTopMask acLeftMask acRightMask) (vla-get-truecolor obj))
)
)
)
(list (vla-get-Columns Obj)(vla-get-Rows Obj))
)
(and (vlax-property-available-p Obj 'RegenerateTableSuppressed)
(vla-put-RegenerateTableSuppressed Obj :vlax-false)
)
) ;_ end of progn
)
) ;_ end of vlax-for
)
)
) ;_ end of if
) ;_ end of vlax-for
(vl-cmdf "_regenall")
) ;_ end of defun

(defun C:BGCOLOR ( / doc col)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(bg:layer-status-save)
(if (setq col (acad_colordlg 256))
(progn
(ChangeAllObjectsColor doc col);_ 7 — םמלונ צגועא
;;;(ChangeXrefAllObjectsColor doc col)
)
)
;;;־בנאבמעךא סעטכוי לףכעטכטםטי
(vl-catch-all-apply
'(lambda ()
(entmod
(mapcar '(lambda (x / y)
(if (= (car x) 350)
(progn
(setq y (mapcar '(lambda (z)
(if (= (car z) 62)
(cons 62 col)
z
) ;_ end of if
) ;_ end of lambda
(entget (cdr x))
) ;_ end of mapcar
) ;_ end of setq
(cons 350 (entmakex y))
) ;_ end of progn
x
) ;_ end of if
) ;_ end of lambda
(dictsearch (namedobjdict) "ACAD_MLINESTYLE")
) ;_ end of mapcar
) ;_ end of entmod
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
(bg:layer-status-restore)
(vla-regen doc acallviewports)
(vla-endundomark doc)
(princ)
)
;;; Returns the list of names of blocks with 1 primitive thing
;;; גמחגנאשאוע סןטסמך טלום בכמךמג ס 1 ןנטלטעטגמל (בכמךט A$C* טכט כ‏בו הנףדטו, סמסעמשטו טח
;;; מהםמדמ ןנטלטעגא ט ‎עמע ןנטלטעטג - בכמך

(defun bg:block-list-one-item ( / Doc Blks blkname)
(setq Doc (vla-get-activedocument (vlax-get-acad-object))
Blks (vla-get-Blocks Doc)
)
(vlax-for Blk Blks
(if (and (= (vla-get-IsXref Blk) :vlax-false)
(= (vla-get-IsLayout Blk) :vlax-false)
(= (vla-get-count Blk) 1)
;;;ֱונול עמכךמ בכמךט "A$C*" ט סמסעמשטו טח הנףדמדמ בכמךא
(or (wcmatch (vla-get-name Blk) "A$C*")
(= (vla-get-ObjectName (vla-item Blk 0)) "AcDbBlockReference")
)
;_ (= (vla-get-ObjectName (vla-item Blk 0)) "AcDbAttributeDefinition")
)
(setq blkname (cons (vla-get-Name Blk) blkname))
)
)
blkname
)

(defun bg:block-GetXclip ( vla-obj / result )
;;;;

;;;http://www.cadtutor.net/forum/showthread.php?63267-Is-there-a-condition-statement-to-find-out-if-Xclip-was-used
;;; ;;; (defun LM:XClipBoundary ( ename / xdict )
;;; ;;; (if
;;; ;;; (setq xdict (cdr (assoc 360 (entget ename))))
;;; ;;; (LM:XClipBoundary xdict)
;;; ;;; (if
;;; ;;; (and
;;; ;;; (eq "SPATIAL_FILTER" (cdr (assoc 0 (setq ename (entget ename)))))
;;; ;;; (eq 1 (cdr (assoc 71 ename)))
;;; ;;; )
;;; ;;; ( (lambda ( massoc ) (massoc 10 ename))
;;; ;;; (lambda ( key elist / item )
;;; ;;; (if (setq item (assoc key elist))
;;; ;;; (cons (cdr item) (massoc key (cdr (member item elist))))
;;; ;;; )
;;; ;;; )
;;; ;;; )
;;; ;;; )
;;; ;;; )
;;; ;;; )

;;;׳ונוח LISP בוח vla
;;; (and (setq blk (car(entsel "\n׃ךאזט ןמהנוחאםםי בכמך")))
;;; (setq dict (cdr(assoc 360 (entget blk))))
;;; (if (and
;;; (setq sp (member '(3 . "ACAD_FILTER") (entget dict)))
;;; (setq sp (cdr(assoc 360 sp)))
;;; (setq sp (member '(3 . "SPATIAL")(entget sp)))
;;; (setq sp (cdr(assoc 360 sp)))
;;; )
;;; (progn
;;; (if (= (cdr(assoc 71 (entget sp))) 1)
;;; (alert "ֱכמך ןמהנוחאם\nֺמםעףנ גךכ‏קום")
;;; (alert "ֱכמך ןמהנוחאם\nֺמםעףנ ־ֺֻׂ׳ֵֽ")
;;; )
;;; )
;;; (alert "ֱכמך םו ןמהנוחאם")
;;; )
;;; )
;;ֵסכט בכמך ןמהנוחאם, גמחגנאשאוע SPATIAL, טםאקו nil
;;If the block is clipped, returns SPATIAL filter, differently return nil
;; test
;; (bg:block-GetXclip (vlax-ename->vla-object(car(entsel "\nSelect clipped xref"))))

(vl-catch-all-apply
'(lambda ( )
(if
(and
(eq (vla-get-ObjectName vla-obj) "AcDbBlockReference")
(eq :vlax-true
(vla-get-HasExtensionDictionary vla-obj)
)
)
(setq result
(entget
(vlax-vla-object->ename
(vla-item
(vla-item
(vla-getExtensiondictionary vla-obj)
"ACAD_FILTER"
)
"SPATIAL"
)
)
)
)
)
)
)

result
)
;;;(defun bg:block-get-name (blkobj)
;;;(cond
;;; ((and (vlax-property-available-p blkobj 'isdynamicblock)
;;; (= (vla-get-isdynamicblock blkobj) :vlax-true)
;;; ) ;_ end of and
;;; (vla-get-effectivename blkobj)
;;; )
;;; (t (vla-get-name blkobj))
;;; ) ;_ end of cond
;;; )

;;; (defun LM:EffectiveName ( blockentity / name repbtag )
;;; ;;----------------=={ Effective Block Name }==----------------;;
;;; ;; ;;
;;; ;; Returns the effective name of a block. ;;
;;; ;;------------------------------------------------------------;;
;;; ;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;; ;;------------------------------------------------------------;;
;;; ;; Arguments: ;;
;;; ;; blockentity - Block Reference Entity name ;;
;;; ;;------------------------------------------------------------;;
;;; ;; Returns: True block name as per the block definition ;;
;;; ;;------------------------------------------------------------;;
;;;
;;; (if (wcmatch (setq name (cdr (assoc 2 (entget blockentity)))) "`**")
;;; (if
;;; (and
;;; (setq repbtag
;;; (cdadr
;;; (assoc -3
;;; (entget
;;; (cdr
;;; (assoc 330
;;; (entget (tblobjname "BLOCK" name))
;;; )
;;; )
;;; '("AcDbBlockRepBTag")
;;; )
;;; )
;;; )
;;; )
;;; (setq repbtag (handent (cdr (assoc 1005 repbtag))))
;;; )
;;; (setq name (cdr (assoc 2 (entget repbtag))))
;;; )
;;; )
;;; name
;;; )

(defun bg:block-get-name (blockentity / name repbtag )
(if (eq (type blockentity) 'VLA-OBJECT)(setq blockentity (vlax-vla-object->ename blockentity)))
;;;get from Lee Mac LM:EffectiveName
;;; http://www.theswamp.org/index.php?topic=37493.0
;;; http://forum.dwg.ru/showthread.php?t=65082
;;----------------=={ Effective Block Name }==----------------;;
;; ;;
;; Returns the effective name of a block. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; blockentity - Block Reference Entity name ;;
;;------------------------------------------------------------;;
;; Returns: True block name as per the block definition ;;
;;------------------------------------------------------------;;

(if (wcmatch (setq name (cdr (assoc 2 (entget blockentity)))) "`**")
(if
(and
(setq repbtag
(cdadr
(assoc -3
(entget
(cdr
(assoc 330
(entget (tblobjname "BLOCK" name))
)
)
'("AcDbBlockRepBTag")
)
)
)
)
(setq repbtag (handent (cdr (assoc 1005 repbtag))))
)
(setq name (cdr (assoc 2 (entget repbtag))))
)
)
name
)

;;; ֲחנגאוע בכמךט, סמסעמשטו טח מהםמדמ ןנטלטעטגא
;;; Explode blocks consisting of one primitive thing (it is possible other block)
(defun bg:block-explode-one-item ( / blklist count xcount tmp)
(bg:layer-status-save)
(setq blklist (bg:block-list-one-item) count 0 xcount 0)
(vlax-for obj (vla-get-block(vla-item (vla-get-Layouts(vla-get-activedocument (vlax-get-acad-object)))(getvar "CTAB")))
(if (and (eq (vla-get-ObjectName obj) "AcDbBlockReference")
(not (vlax-property-available-p obj 'path))
(vl-position (bg:block-get-name obj) blklist)
)
(progn
(if (and (setq tmp (bg:block-GetXclip obj))
(= 1 (cdr(assoc 71 tmp)))
)
(progn
;;; ַהוס המכזםא בע נואךצט םא ןמהנוחאםםי בכמך
;;; ָדםמנטנףול
(setq xcount (1+ xcount))
)
(progn
(bg:explode-block (vlax-vla-object->ename obj) nil)
(setq count (1+ count))
)
)
)
)
)
(bg:layer-status-restore)
(list count xcount)
)

;;en -ename
;;Rdn - string name of appid or nil -all
;;׃האכטע גסו ׀אסרטנוםםו האםםו ( XDATA ׀ִ )
(defun bg:del-XDATA-from-ename (en Rdn / elist sub)
(if (= (type en) 'vla-object)
(setq en (vlax-vla-object->ename en))
)
(setq elist (entget en (list "*")))
(if (null Rdn)
(progn
(setq sub (mapcar 'car (cdr (assoc -3 elist))))
(setq sub (vl-remove-if
'(lambda (x) (wcmatch (strcase x) "ACAD*,ACDB*"))
sub
)
)
(if sub
(progn
(setq sub (list (cons -3 (mapcar 'list sub))))
(entmod (append (entget en) sub))
)
)
)
(progn
(foreach i (cdr (assoc -3 elist))
(if (not (wcmatch (strcase (car i)) (strcase Rdn)))
(setq sub (append sub (list i)))
(setq sub (append sub (list (list (car i)))))
)
)
(setq sub (cons -3 sub)
elist (subst sub (assoc -3 elist) elist)
elist (entmod elist)
)
)
)
)
(defun bg:get-all-atts (obj)
(if (and obj
(vlax-property-available-p obj 'Hasattributes)
(eq :vlax-true (vla-get-HasAttributes obj))
)
(vl-catch-all-apply
(function
(lambda ()
(mapcar (function (lambda (x)
(cons (vla-get-TagString x)
(bg:FieldCode (vlax-vla-object->ename x))
;;; ֽו טסןמכחףול (vla-get-TextString x), ע.ך וסכט אענטבףע סמהונזטע UNICOD סטלגמכ
;;; םאןנטלונ "ֽ\U+2082־", עמ (vla-get-TextString x) גונםוע "ֽ?־" + סמץנאםול, וסכט וסע ןמכ
)
)
)
(append (vlax-invoke obj 'Getattributes)
(vlax-invoke obj 'Getconstantattributes)
)
)
)
)
)
)
)
(defun bg:set-atts-bylist (block att_list)
;; obj - Ename or Vla object of block
;; att_list - list ((Tag_Name1 . Value1)(Tag_Name2 . Value2) ...)
;; Tag_Name - string
;; Value - string
(if (= (type block) 'ENAME)(setq block (vlax-ename->vla-object block)))
(setq att_list (mapcar '(lambda(x)(cons (strcase (car x))(cdr x))) att_list))
(if (and block
(vlax-write-enabled-p block)
(not(vlax-erased-p block))
(= (vla-get-ObjectName block) "AcDbBlockReference")
(vlax-property-available-p block 'Hasattributes)
(eq :vlax-true (vla-get-HasAttributes block))
)
(mapcar
(function
(lambda ( attrib / tmp )
(if (setq tmp (assoc(strcase(vla-get-TagString attrib)) att_list))
(progn
(vla-put-TextString attrib " ")
(vla-put-TextString attrib (cdr tmp))
)
)
)
)
(vlax-invoke block 'GetAttributes)
)
)
)
(defun bg:DynToStatic ( obj ConvertMode / i name ret attlist)
;;; obj - vla object
;;; ConvertMode - nil ConvertToAnonymousBlock
;;; - t ConvertToStaticBlock
;;; Return - t - if converted or nil if error
;;;"ConvertToStaticBlock" or "ConvertToAnonymousBlock"
(if (= (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
;;; (setq attlist (bg:get-all-atts obj))
(cond
((and ConvertMode
(vlax-write-enabled-p obj)
(vlax-method-applicable-p obj "ConvertToStaticBlock")
)
(setq name (strcat "$BG$_" (substr (rtos (getvar "CDATE") 2 9) 10) "_"))
(setq i 1)
(while (tblsearch "Block" (strcat name (itoa i)))(setq i (1+ i)))
(setq name (strcat name (itoa i)))
(setq ret
(not
(VL-CATCH-ALL-ERROR-P
(vl-catch-all-apply 'vlax-invoke (list obj "ConvertToStaticBlock" name))
)
)
)
)
((and (not ConvertMode)
(vlax-write-enabled-p obj)
(vlax-method-applicable-p obj "ConvertToAnonymousBlock")
)
(setq ret
(not
(VL-CATCH-ALL-ERROR-P
(vl-catch-all-apply 'vlax-invoke (list obj "ConvertToAnonymousBlock"))
)
)
)
)
(t nil)
)
;;; Add VVA 2014-10-08 v.2.28
(vl-catch-all-apply
'(lambda()
(vlax-map-Collection
(vla-item (vla-get-Blocks(vla-get-activedocument (vlax-get-acad-object)))(vla-get-name obj))
'(lambda (x)(if(eq(vla-get-Visible x) :vlax-false)(vla-delete x)))
)
)
)

;;;VVA 2011-11-09 Remove
;;; (if (and ret attlist)
;;; (progn
;;; (bg:set-atts-bylist obj attlist)
;;; (command "_.Updatefield" (vlax-vla-object->ename obj) "")
;;; (while (> (getvar "CMDACTIVE") 0) (command ""))
;;; )
;;; )
ret
)

(defun bg:ConvertDynBlock ( ConvertMode selectall / doc ss i *error* obj name j k str)
;;; ConvertMode - nil ConvertToAnonymousBlock
;;; - t ConvertToStaticBlock
;;; selectall - t - select all
;;; - nil - select
;;; Use (bg:ConvertDynBlock nil nil)
;;; Use (bg:ConvertDynBlock t nil)
(defun *error* (msg)
(princ msg)
(vla-endundomark doc)
(bg:layer-status-restore)
)
(vl-load-com)
(if ConvertMode
(setq str "ConvertToStaticBlock")
(setq str "ConvertToAnonymousBlock")
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(if (null selectall)
(progn
(princ
(strcat "\n<> "
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"ֲבונטעו הטםאלטקוסךטו בכמךט"
"Select dynamic blocks"
)
)
)
(setq ss (ssget "_I" '((0 . "Insert"))))
)
)
(SSSETFIRST)
(vla-startundomark doc)
(bg:layer-status-save)
(if
(if selectall
(setq ss (ssget "_X" '((0 . "Insert"))))
(or ss (setq ss (ssget "_:L" '((0 . "Insert")))))
)
(repeat (setq k 0 i (sslength ss))
(setq obj (vlax-ename->vla-object(ssname ss (setq i (1- i)))))
(if (and (vlax-write-enabled-p obj)
(= (vla-get-isdynamicblock obj) :vlax-true)
(vlax-method-applicable-p obj str)
(setq k (1+ k))
)
(bg:DynToStatic obj ConvertMode)
)
)
)
(bg:layer-status-restore)
(vla-regen doc acallviewports)
(vla-endundomark doc)
(terpri)(princ str)(princ " - ")(princ k)
(princ)
)
(defun C:BGBLDYN2A ()
;;; Conver Dynamic Blocks to Anonymous
(bg:ConvertDynBlock nil nil)
)
(defun C:BGBLDYN2S ()
;;; Conver Dynamic Blocks to Static
(bg:ConvertDynBlock t nil)
)
(defun C:BGBLALLDYN2A ()
;;; Conver ALL Dynamic Blocks to Anonymous
(bg:ConvertDynBlock nil t)
)
(defun C:BGBLALLDYN2S ()
;;; Conver ALL Dynamic Blocks to Static
(bg:ConvertDynBlock t t)
)

(defun c:BGBLXCLIPEXP( / ent)
(vl-load-com)
((lambda(ent actdoc)
(vla-startundomark actdoc)
(if (and ent
(not (vl-catch-all-error-p ent))
)
((lambda(obj point)
(if (bg:block-GetXclip (vlax-ename->vla-object obj))
(bg:block-xclip-exp obj point)
(prompt (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\n׃ךאחאםםי בכמך םו ןמהנוחאם" "\nThe specified block is not clipped"))
)
)
(car ent)
(cadr ent)
)
)
(vla-endundomark actdoc)
)
(vl-catch-all-apply 'entsel
(list (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\n׃ךאזטעו ןמהנוחאםםי בכמך: " "\nSelect clipped block"))
)
(vla-get-activedocument (vlax-get-acad-object))
)
(princ)
); end c:BGBLXCLIPEXP

(defun bg:block-xclip-exp(blk point / pline_obj *error*)
(defun *error* (msg)
(princ msg)
(mapcar '(lambda (x)(if(vlax-write-enabled-p x)(vla-put-visible x :vlax-true))) hiden)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)

(if (vl-cmdf "_.xclip" blk "" "_P")
((lambda(pline_obj)
(vl-cmdf "_.zoom" "_O" pline_obj "")
((lambda(lst_exp_obj lst_xclip eps)
(if (and lst_exp_obj
lst_xclip
)
((lambda(is_int_point)
((lambda(nbr_xclip pline_trim / i e1)
(setq i 0 ss (ssadd))
(while (vla-object(setq e1(ssname nbr_xclip i))) lst_exp_obj))
(progn
(setq hiden (cons (vlax-ename->vla-object e1) hiden))
(ssdel e1 nbr_xclip)
)
(setq i (1+ i))
)
)
(mapcar '(lambda (x)(if(vlax-write-enabled-p x)(vla-put-visible x :vlax-false))) hiden)
(VL-CATCH-ALL-APPLY '(lambda()
(if (and nbr_xclip pline_trim)
(progn
(foreach item (mapcar 'vlax-vla-object->ename lst_exp_obj)
(if is_int_point
(if (not (ssmemb item nbr_xclip))
(entdel item)
)
(if (ssmemb item nbr_xclip)
(entdel item)
)
)
)
(apply 'vl-cmdf (append (list "_.trim" pline_obj "" "_F")
((lambda(ed_pline_trim)
(append (mapcar 'cdr (vl-remove-if-not (function (lambda(x) (= (car x) 10)))
ed_pline_trim
)
)
(list (cdr (assoc 10 ed_pline_trim)))
)
)
(entget pline_trim)
)
(list "" "")
)
)
(entdel pline_trim)
)
)
))
(mapcar '(lambda (x)(if(vlax-write-enabled-p x)(vla-put-visible x :vlax-true))) hiden)
(vl-cmdf "_.zoom" "_P")
)
(if is_int_point
(ssget "_CP" lst_xclip)
(ssget "_WP" lst_xclip)
)
((lambda(reverse-point)
(if reverse-point
(if (vl-cmdf "_.offset" eps pline_obj (get-reverse-point point pline_obj 0.1) "")
(entlast)
)
)
)
(get-reverse-point point pline_obj 0.1)
)
)
)
((lambda(point_obj / result)
(setq result (ssmemb point_obj (ssget "_CP" lst_xclip)))
(entdel point_obj)
result
)
(entmakex (list '(0 . "POINT") (cons 10 point)))
)
)
)
)
(bg:burst-list blk)
(mapcar 'cdr (vl-remove-if-not (function (lambda(x) (= (car x) 10))) (entget pline_obj)))
(min 0.1 (* (getvar 'viewsize) 0.01))
)
(entdel pline_obj)
(vl-cmdf "_.zoom" "_P")
)
(entlast)
)
)
); end bg:block-xclip-exp

(defun get-reverse-point(pt obj e / )
((lambda(cl_pt)
(if cl_pt
((lambda(param_cl_pt end_param)
(if param_cl_pt
((lambda(p1 p2)
(if (not p1) (setq p1 (vlax-curve-getPointAtParam obj e)))
(if (not p2) (setq p2 (vlax-curve-getPointAtParam obj (- end_param e))))
((lambda(c_p)
(polar pt (angle pt c_p) (+ (distance pt c_p) e))
)
(polar p1 (angle p1 p2) (* (distance p1 p2) 0.5))
)
)
(vlax-curve-getPointAtParam obj (+ param_cl_pt e))
(vlax-curve-getPointAtParam obj (- param_cl_pt e))
)
)
)
(vlax-curve-getParamAtPoint obj cl_pt)
(vlax-curve-getEndParam obj)
)
)
)
(vlax-curve-getClosestPointTo obj pt)
)
); end get-reverse-point
(defun c:BGBLCC () (bg:block-color) (princ))
(defun c:BGENCC () (pl:block-ent-color) (princ))
;;; Alaspher encc http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
(defun pl:block-ent-color (/ adoc color ent lays)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
lays (vla-get-layers adoc)
color (cond
((and (listp *BG-COLOR*)(assoc 430 *BG-COLOR*))
(acad_truecolordlg (assoc 430 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 420 *BG-COLOR*))
(acad_truecolordlg (assoc 420 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 62 *BG-COLOR*))
(acad_truecolordlg (assoc 62 *BG-COLOR*))
)
(t (acad_truecolordlg 256)) ;_(acad_truecolordlg (assoc 420 color))
)
*BG-COLOR* color
)
(if color
(progn (setvar "errno" 0)
(vla-startundomark adoc)
(while (and (not (vl-catch-all-error-p
(setq ent (vl-catch-all-apply
(function nentsel)
'("\nSelect entity :")
)
)
)
)
(/= 52 (getvar "errno"))
)
(if ent
(progn (setq ent (vlax-ename->vla-object (car ent))
lay (vla-item lays (vla-get-layer ent))
)
(if (= (vla-get-lock lay) :vlax-true)
(progn (setq layloc (cons lay layloc))
(vla-put-lock lay :vlax-false)
)
)
;(vl-catch-all-apply (function vla-put-color) (list ent color))
(vl-catch-all-apply (function bg:put-color) (list ent color))
(vla-regen adoc acallviewports)
)
(princ "\nNothing selection! Try again.")
)
)
(foreach i layloc (vla-put-lock i :vlax-true))
(vla-endundomark adoc)
)
)
(princ)
)
;;;ֽא מסםמגו Alaspher blcc encc http://forum.dwg.ru/showthread.php?t=1036
(defun bg:block-color (/ adoc blocks color ins lays ss e2)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blocks (vla-get-blocks adoc)
lays (vla-get-layers adoc)
color (cond
((and (listp *BG-COLOR*)(assoc 430 *BG-COLOR*))
(acad_truecolordlg (assoc 430 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 420 *BG-COLOR*))
(acad_truecolordlg (assoc 420 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 62 *BG-COLOR*))
(acad_truecolordlg (assoc 62 *BG-COLOR*))
)
(t (acad_truecolordlg 256)) ;_(acad_truecolordlg (assoc 420 color))
)
*BG-COLOR* color
)
(if color
(progn (setvar "errno" 0)
(vla-startundomark adoc)
(while (and (not (vl-catch-all-error-p
(setq ins (vl-catch-all-apply
(function entsel)
(list (if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"\nֲבונטעו בכמך :"
"\nSelect block :")
)
)
)
)
)
(/= 52 (getvar "errno"))
)
(if ins
(progn
(setq ss (vlax-ename->vla-object (car ins)))
(if (= (vla-get-objectname ss) "AcDbBlockReference")
(if (vlax-property-available-p ss 'path)
(princ "\nThis is external reference! Try pick other.")
(progn
(bg:layer-status-save)
(_pl:block-color blocks ss color lays)
(if (setq ss nil
ss (ssget "_X"
(list
(cons 2
(strcat
(if (wcmatch(cdr(assoc 2 (entget(car ins)))) "`**")
"`"
""
)
(cdr(assoc 2 (entget(car ins))))
)
)
(cons 66 1)
(cons 410 (getvar "CTAB"))
)
)
)
(progn
(foreach blk (mapcar (function vlax-ename->vla-object) (vl-remove-if (function listp)
(mapcar (function cadr) (ssnamex ss))))
(foreach at (vlax-invoke blk 'Getattributes)
;;; (vl-catch-all-apply
;;; (function vla-put-color)(list at color))
(vl-catch-all-apply
(function
(lambda()
(entmod
(append
(vl-remove-if '(lambda(x)(member(car x) '(62 420 430)))
(entget(vlax-vla-object->ename at))
)
color
)
)
)
)
)
)
)
)
)
(bg:layer-status-restore)
(vla-regen adoc acallviewports)
)
)
(princ "\nThis isn't block! Try pick other.")
)
)
(princ "\nNothing selection! Try again.")
)
)
(vla-endundomark adoc)
)
)
(princ)
)
(defun bg:put-color ( e color / TrueColor)
;;; e - vla-object
;;; color - list what return acad_truecolordlg
(if (equal (vla-get-ObjectName e) "AcDbZombieEntity")
(princ "\nskip proxy entities ")
(cond
((and
(= color -1)
(not(eq (vla-get-color e) acByBlock))
(not(eq (vla-get-color e) acByLayer))
)
(setq TrueColor (vla-get-truecolor e))
(vla-setrgb TrueColor
(vla-get-red TrueColor)
(vla-get-green TrueColor)
(vla-get-blue TrueColor)
) ;_ end of vla-setRGB
(vl-catch-all-apply (function vla-put-Truecolor) (list e TrueColor))
)
((listp color)
(vl-catch-all-apply
(function
(lambda ()
(entupd
(cdr
(assoc
-1
(entmod
(append
(vl-remove-if
'(lambda (x) (member (car x) '(62 420 430)))
(entget (vlax-vla-object->ename e))
) ;_ end of vl-remove-if
color
) ;_ end of append
) ;_ end of entmod
) ;_ end of assoc
) ;_ end of cdr
) ;_ end of entupd
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
(vl-catch-all-apply (function vla-update) (list e))
)
((numberp color)
(vl-catch-all-apply (function vla-put-color) (list e color))
)
(t nil)
)
)
)
(defun _pl:block-color (blocks ins color lays / lay layfrz layloc c ee TrueColor)
;;;color >0 - ACI color
;;; -1 - convert to RGB

(vlax-for e (vla-item
blocks
(vla-get-name ins)
;;; (if (vlax-property-available-p ins 'EffectiveName)
;;; (vla-get-effectivename ins)
;;; (vla-get-name ins)
;;; ) ;_ end of if
) ;_ end of vla-item
(setq lay (vla-item lays (vla-get-layer e)))
(if (= (vla-get-freeze lay) :vlax-true)
(progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
)
(if (= (vla-get-lock lay) :vlax-true)
(progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
)
(bg:put-color e color)
(if (and (= (vla-get-objectname e) "AcDbBlockReference")
(not (vlax-property-available-p e 'path))
)
(_pl:block-color blocks e color lays)
)
(foreach i layfrz (vla-put-freeze i :vlax-true))
(foreach i layloc (vla-put-lock i :vlax-true))
)
)

(defun bg:DetachImage (ImgName)
(vl-catch-all-apply
'(lambda ()
(vla-delete
(vla-item
(vla-item
(vla-get-dictionaries
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-dictionaries
"ACAD_IMAGE_DICT"
) ;_ end of vla-Item
ImgName
) ;_ end of vla-Item
) ;_ end of vla-Delete
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of defun

;;;׃האכוםטו גסודמ ס גךכ‏קוםםץ ט חאלמנמזוםםץ סכמוג
(defun bg:delete-from-layer (/ layer-list
aDOC count
*error* all_raster_image_name
used_raster_image_name
ignore-block-list
)
;;;׃האכוםטו גסודמ ס גךכ‏קוםםץ ט חאלמנמזוםםץ סכמוג
(defun *error* (msg)
(setvar "MODEMACRO" "")
(princ msg)
(vla-regen aDOC acactiveviewport)
(bg:progress-clear)
(princ)
) ;_ end of defun
(defun _loc-delete-items ()
(if (= (vla-get-IsXref Blk) :vlax-false)
(progn
(setq count 0)
(if (> (vla-get-count Blk) 100)
(bg:progress-init
(strcat (vla-get-name Blk) " :")
(vla-get-count Blk)
) ;_ end of bg:progress-init
(progn
(setvar "MODEMACRO" (vla-get-name Blk))
) ;_ end of progn
) ;_ end of if
(vlax-for Obj Blk
(if (and
(= (vla-get-ObjectName Obj) "AcDbRasterImage")
(vlax-property-available-p obj 'Name)
(not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-get-name (list obj))
) ;_ end of vl-catch-all-error-p
) ;_ end of not
(vlax-property-available-p obj 'ImageFile)
) ;_ end of and
(setq used_raster_image_name
(cons (vla-get-Name Obj)
used_raster_image_name
) ;_ end of cons
) ;_ end of setq
) ;_ end of if
;;;ֲ עאבכטצו מןטסאםט בכמךא מסעאגכול ןנטלטעטג םא 0 סכמו ג כ‏במל סכףקאו
(if (or
(eq (vla-get-IsLayout Blk) :vlax-true)
(and (eq (vla-get-IsLayout Blk) :vlax-false)
(= (vla-get-ObjectName Blk) "AcDbBlockTableRecord")
(/= (vla-get-layer Obj) "0")
) ;_ end of and
) ;_ end of or
(vl-catch-all-apply
'(lambda ()
(bg:progress (setq count (1+ count)))
(if (vlax-write-enabled-p Obj)
(if
(and (vlax-property-available-p Obj 'Layer)
(vl-position (vla-get-layer Obj) layer-list)
) ;_ end of and
;ObjectName (RO) = "AcDbBlockReference"
;ObjectName (RO) = "AcDbBlockTableRecord"
(if (= (vla-get-ObjectName Obj)
"AcDbBlockReference"
) ;_ end of =
(if (not (vl-position
(vla-get-name Obj)
ignore-block-list
) ;_ end of vl-position
) ;_ end of not
(vl-catch-all-apply 'vla-delete (list Obj)) ;_ Delete BlockReference object
) ;_ end of if
(vl-catch-all-apply 'vla-delete (list Obj)) ;_ Delete OTHER object
) ;_ end of if
(vl-catch-all-apply
'bg:del-XDATA-from-ename
(list Obj nil)
) ;_Delete Appid from Object
) ;_ end of if
) ;_ end of if
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of if
) ;_ end of vlax-for
(bg:progress-clear)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(setq layer-list nil
aDOC (vla-get-activedocument (vlax-get-acad-object))
) ;_ end of setq
;;; (grtext -1 "Stage 1. Viewing of layers")
(vlax-for item (vla-get-layers aDOC)
(if (or (= (vla-get-freeze item) :vlax-true)
(= (vla-get-layeron item) :vlax-false)
) ;_ end of or
(if (not(wcmatch (vla-get-name item) "*|*"))(setq layer-list (cons (vla-get-name item) layer-list)))
) ;_ end of if
) ;_ end of vlax-for
(bg:layer-status-save)
(setq layer-list (vl-remove-if-not 'snvalid layer-list))
;;; (grtext -1 "Stage 1. Viewing of layers")
(if layer-list
(progn
(setq ignore-block-list nil)
(vlax-for Blk (vla-get-Blocks aDOC)
;;;2 צטךכא: ןמ מןטסאםטל בכמךמג ט ןמ כטסעאל
;;; ignore-block-list - סןטסמך בכמךמג
;;; טלו‏שטץ ץמע ב מהטם ‎כולוםע םא גךכ‏קוםםמל סכמו
(if (eq (vla-get-IsLayout Blk) :vlax-false) ;_ 1-י צטךכ ןמ בכמךאל
(progn
(_loc-delete-items)
(setq count nil)
(vlax-for Obj Blk
(if
(and (/= (vla-get-layer Obj) "0")
(not (vl-position (vla-get-layer Obj) layer-list))
) ;_ end of and
(setq ignore-block-list
(cons (vla-get-Name Blk)
ignore-block-list
) ;_ end of cons
) ;_ end of setq
) ;_ end of if
) ;_ end of vlax-for

) ;_ end of progn
) ;_ end of if
) ;_ end of vlax-for
;;;2 צטךכא: ןמ מןטסאםטל בכמךמג ט ןמ כטסעאל
(vlax-for Blk (vla-get-Blocks aDOC)
;;; ignore-block-list - סןטסמך בכמךמג
;;; טלו‏שטץ ץמע ב מהטם ‎כולוםע םא גךכ‏קוםםמל סכמו
(if (eq (vla-get-IsLayout Blk) :vlax-true)
(_loc-delete-items)
) ;_ end of if
) ;_ end of vlax-for
) ;_ end of progn
) ;_ end of if
;;; (grtext -1 "Stage 3. Audit and Purge")
(vla-auditinfo aDOC :vlax-true)
;;;Audit
(repeat 3 (vla-purgeall aDOC))
(if (and layer-list
(setq all_raster_image_name
(mapcar 'cdr
(vl-remove-if-not
(function (lambda (x) (= 3 (car x))))
(dictsearch (namedobjdict) "ACAD_IMAGE_DICT")
) ;_ end of vl-remove-if-not
) ;_ end of mapcar
) ;_ end of setq
)
(setq all_raster_image_name (mapcar 'strcase all_raster_image_name))
) ;_ end of if
(setq used_raster_image_name (mapcar 'strcase used_raster_image_name))
(mapcar
'(lambda (img)
(setq all_raster_image_name
(vl-remove img all_raster_image_name)
) ;_ end of setq
) ;_ end of lambda
used_raster_image_name
) ;_ end of mapcar
(mapcar 'bg:DetachImage all_raster_image_name)
;;; (vl-cmdf "_.Redrawall")
(vla-regen aDOC acActiveViewport)
(BG:LAYER-STATUS-RESTORE)
(setq *BG_LAYER_LST* nil)
) ;_ end of defun
(defun bg:conv-to-str (dat)
(cond ((= (type dat) 'INT)(setq dat (itoa dat)))
((= (type dat) 'REAL)(setq dat (rtos dat 2 12)))
((null dat)(setq dat ""))
(t (setq dat (vl-princ-to-string dat)))))
(Defun LASTENT (/ E0 EN)
;-----------------------------------------------------
; Find True last entity
;-----------------------------------------------------

(Setq E0 (EntLast))
(While (Setq EN (EntNext E0))
(Setq E0 EN)
)
E0
)
;-----------------------------------------------------
; See if a block is explodable. Return T if it is,
; otherwise return nil
;-----------------------------------------------------

(Defun bg:EXPLODABLE (BNAME / B expld)
(setq BLOCKS (vla-get-blocks
(vla-get-ActiveDocument (vlax-get-acad-object)))
)

(vlax-for B BLOCKS (if (and (= :vlax-false (vla-get-islayout B))
(= (strcase (vla-get-name B)) (strcase BNAME))
)
(if (vlax-property-available-p B "explodable") ;;; VVA Correct to 2004 AutoCAD
(setq expld (= :vlax-true (vla-get-explodable B)))
(setq expld t)
)
)
)
expld
)

(defun bg:del-from-list ( pat lst / tmp )
(foreach item lst
(if (/= (car item) pat)
(setq tmp (cons item tmp))
)
)
(reverse tmp)
)
;;;ֿמ אםאכמדטט ס BURST-ONE
(Defun bg:BURST-ONE (BNAME / BBLOCK BENT ANAME ENT ATYPE
AENT AGAIN ENAME ENT SS-COLOR SS-LAYER
SS-LTYPE SS-LWEIGHT mirror ss-mirror TMP mlast BLAYER BCOLOR BLTYPE BLWEIGHT
attlist BOBJ _ITEM _bump _ATT-TEXT SS-ATTR
)
;;;********* װ-צטט גהנאם טח BURST.LSP ************
;;; ֽאכטקטו Express מבחאעוכםא !!!
(Defun _ITEM (N E) (CDR (Assoc N E)))
;;;(acet-error-init (list (list "cmdecho" 0
;;;"highlight" 1) T))
;;;(Defun _BITSET (A B) (= (Boole 1 A B) B))
(Defun _bump (prmpt)(GRTEXT -2 prmpt))

(Defun _ATT-TEXT (AENT / ANAME TENT ILIST INUM lineweight)
(setq ANAME (cdr (assoc -1 AENT)))
(if (and _MATTS_UTIL (_MATTS_UTIL ANAME))
(progn
; Multiple Line Text Attributes (MATTS) -
; make an MTEXT entity from the MATTS data
(_MATTS_UTIL ANAME 1)
)
(progn
; else -Single line attribute conversion
(Setq TENT '((0 . "TEXT")))
(ForEach INUM '(8 6 38 39 62 67 210 10 40 50 41 51 7 71 72 73 11 74)
(If (Setq ILIST (Assoc INUM AENT))
(Setq TENT (Cons ILIST TENT))
)
)
(if (setq ILIST (bg:FieldCode ANAME)) ;;;_ Add VVA 2016-03-24
(Setq TENT (Cons (cons 1 ILIST) TENT))
(Setq TENT (Cons (Assoc 1 AENT) TENT))
)
(Setq
tent (Subst
(Cons 73 (_ITEM 74 aent))
(Assoc 74 tent)
tent
)
)
;;; VVA ADD 2011-10-26 BEGIN
((lambda ( itm / ed next)
(setq next t)
(while (and next (setq itm (entnext itm)))
(setq ed (entget itm))
(if (and (= (_ITEM 0 ed) "ATTDEF")
(= (_ITEM 2 ed)(_ITEM 2 AENT))
)
(setq next nil lineweight (_ITEM 370 ed))
)
)
)
(tblobjname "BLOCK" (bg:block-get-name (cdr(assoc 330 AENT))))
)
(cond
((= lineweight '-3) ;_default lineweight
(setq TENT (cons (cons 370 (getvar "LWDEFAULT")) TENT))
)
((= lineweight '-2) ;_byblock lineweight
(if (setq lineweight (cdr(assoc 370 (entget(cdr(assoc 330 AENT))))))
(setq TENT (cons (cons 370 lineweight) TENT))
((lambda ( lw )
(cond
((= lw '-3)
(setq TENT (cons (cons 370 (getvar "LWDEFAULT")) TENT))
)
((numberp lw)
(setq TENT (cons (cons 370 lw) TENT))
)
(t nil)
)
)
(cdr(assoc 370 (entget(TBLOBJNAME "LAYER" (cdr(assoc 8 (entget(cdr(assoc 330 AENT)))))))))
)
)
)
((and lineweight (not (minusp lineweight)))
(setq TENT (cons (cons 370 lineweight) TENT))
)
(t ;_bylayer
((lambda ( lw )
(cond
((= lw '-3)
(setq TENT (cons (cons 370 (getvar "LWDEFAULT")) TENT))
)
((numberp lw)
(setq TENT (cons (cons 370 lw) TENT))
)
(t nil)
)
)
(cdr(assoc 370 (entget(TBLOBJNAME "LAYER" (cdr(assoc 8 (entget(cdr(assoc 330 AENT)))))))))
)
)
)

;;; VVA ADD 2011-10-26 END

(EntMakex (Reverse TENT))
(if ILIST (vl-cmdf "_.updatefield" (entlast) "")) ;;;_ Add VVA 2016-03-24
)
)
) ;_ end of Defun
(Setq BENT (EntGet BNAME)
BOBJ (vlax-ename->vla-object BNAME)
BLAYER (vla-get-Layer BOBJ)
BCOLOR (vla-get-Color BOBJ)
BBLOCK (bg:block-get-name BNAME) ;;; (_ITEM 2 BENT)
BLTYPE (vla-get-linetype BOBJ)
BLWEIGHT (vla-get-LineWeight BOBJ)
SS-ATTR (ssadd)
)
(Setq ELAST (LASTENT) attlist nil)
(if (bg:EXPLODABLE BBLOCK)
(progn
(If (= 1 (_ITEM 66 BENT))
(Progn (Setq ANAME BNAME)
(While (Setq ANAME (EntNext ANAME)
AENT (EntGet ANAME)
ATYPE (_ITEM 0 AENT)
AGAIN (= "ATTRIB" ATYPE)
)
;;; (_bump "Converting attributes")
;;;-> VVA 30.07.2008
(if (or (null(_ITEM 60 AENT))
(/= (_ITEM 60 AENT) 1) ;_ Visible ON (check dxf code 60) if code 60 set to 1 - object invivible
)
(if (or
(zerop (logand (_ITEM 70 AENT) 1)) ;_Change by VVA Attr fix 03.09.2008 Not hidden attribute
(zerop (logand (_ITEM 70 AENT) 9)) ;_Add kakt00z 1.06.2010 ( http://forum.dwg.ru/showpost.php?p=580531&postcount=33 )
)
(progn
(setq tmp (cdr (assoc 2 AENT))) ;_ add VVA 20.03.2009
(_ATT-TEXT AENT) ;_Change by VVA Attr fix 03.09.2008
(setq attlist (cons (list tmp (entlast)) attlist)) ;_ add VVA 20.03.2009
)
)
)
)
)
)
;;;vla-object BNAME)))
)
(acet-explode BNAME)
(VL-CATCH-ALL-APPLY 'vla-delete (list(vlax-ename->vla-object BNAME)))
)
(Setq SS-LAYER nil
SS-COLOR nil
SS-LTYPE nil
SS-LWEIGHT nil ;_Add VVA BURST LWEIGHT SECTION
ENAME ELAST
)
;;; (_bump "Gathering pieces")
(While (Setq ENAME (EntNext ENAME))
(Setq ENT (EntGet ENAME)
ETYPE (_ITEM 0 ENT)
)
(cond
((= "ATTDEF" ETYPE)
(setq tmp (cdr(assoc 2 ENT))) ;_ add VVA 20.03.2009
(if (cadr (assoc tmp attlist))
(ssadd (cadr (assoc tmp attlist)) SS-ATTR)
)
(setq attlist (bg:del-from-list tmp attlist)) ;_ add VVA 13.07.2010
;;; (If (_BITSET (_ITEM 70 ENT) 2) ;_Rem by VVA Attr fix 03.09.2008
;;; (ATT-TEXT ENT) ;_Rem by VVA Attr fix 03.09.2008
;;; ) ;_Rem by VVA Attr fix 03.09.2008
(EntDel ENAME)
)
((= "SEQEND" ETYPE) nil)
((and (_ITEM 60 ENT);_(check Visible dxf code 60) if code 60 set to 1 - object invisible
(= 1 (_ITEM 60 ENT))
)
(VL-CATCH-ALL-APPLY 'entdel (list ENAME))
)
(t ;_Other entyties
(If (= "0" (_ITEM 8 ENT))
(setq SS-LAYER (cons ENAME SS-LAYER))
)
(If (= 0 (_ITEM 62 ENT)) ;_ -> START Change VVA BURST
(if (= "0" (_ITEM 8 ENT))
(setq SS-COLOR (cons ENAME SS-COLOR))
(progn
(if (null (_ITEM 62 BENT)) ;_Block color type bylayer
;;;(command "_.chprop" ENAME "" "_C" (_ITEM 62 (entget (TBLOBJNAME "LAYER" BLAYER))) "")
(bg:change-prop ENAME "Color" (_ITEM 62 (entget (TBLOBJNAME "LAYER" BLAYER))))
(setq SS-COLOR (cons ENAME SS-COLOR))
)
)
) ;_ START Change VVA BURST
(if (= "0" (_ITEM 8 ENT))
(setq SS-LTYPE (cons ENAME SS-LTYPE))
(progn
(if (= "BYLAYER" (strcase (cond ((_ITEM 6 BENT))("BYLAYER")))) ;_Block line type bylayer
;;;(command "_.chprop" ENAME "" "_LT" (_ITEM 6 (entget (TBLOBJNAME "LAYER" BLAYER))) "")
(bg:change-prop ENAME "Linetype" (_ITEM 6 (entget (TBLOBJNAME "LAYER" BLAYER))))
(setq SS-LTYPE (cons ENAME SS-LTYPE) )
)
)
)
) ;_ START Change VVA BURST LWEIGHT SECTION
(If (= -2 (_ITEM 370 ENT)) ;_ -> BYBLOCK LWEIGHT
(if (= "0" (_ITEM 8 ENT))
(setq SS-LWEIGHT (cons ENAME SS-LWEIGHT))
(progn
(if (NOT (_ITEM 370 BENT)) ;_Block LWEIGHT BYLAYER
(bg:change-prop ENAME "LineWeight" (vla-get-LineWeight (vlax-ename->vla-object (TBLOBJNAME "LAYER" BLAYER))))
(setq SS-LWEIGHT (cons ENAME SS-LWEIGHT))
)
)
)
)
;_ (sslength SS-ATTR) 0)(command "_draworder" SS-ATTR "" "_f"))
(setq SS-LAYER nil SS-COLOR nil SS-LTYPE nil SS-LWEIGHT NIL SS-ATTR NIL)
)
(defun bg:change-prop ( obj prop value)
(if (= (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
(if (and
(vlax-write-enabled-p obj)
(vlax-property-available-p obj prop)
)
(vl-catch-all-apply 'vlax-put-property (list obj prop value))
)
)

;;; ׁןנטסמך גכמזוםםץ בכמךמג גכמזוםו בכמךט nested block
;;; list of nested block
;;; http://www.cadtutor.net/forum/showthread.php?t=48702
;;; http://www.theswamp.org/index.php?topic=40367.0
;;; סל.BlockCount V1-2.lsp Lee MAc
;;; (defun c:NestSel ( / ss def n l )
;;; ;; © Lee Mac ~ 03.06.10
;;; (vl-load-com)
;;;
;;; (while (setq def (tblnext "BLOCK" (not def)))
;;; (if (ContainsNested (tblobjname "BLOCK" (setq n (cdr (assoc 2 def)))))
;;; (setq l (cons n l))
;;; )
;;; )
;;;
;;; (if l
;;; (sssetfirst nil
;;; (ssget "_X"
;;; (list '(0 . "INSERT") (cons 2 (lst->str l ",")))
;;; )
;;; )
;;; )
;;; (princ)
;;; )
;;;
;;; (defun ContainsNested ( ent / foo )
;;; ;; © Lee Mac ~ 03.06.10
;;;
;;; (defun foo ( e )
;;; (if (setq e (entnext e))
;;; (cons e (foo e))
;;; )
;;; )
;;;
;;; (vl-some
;;; (function
;;; (lambda ( x )
;;; (eq "INSERT" (cdr (assoc 0 (entget x))))
;;; )
;;; )
;;; (foo ent)
;;; )
;;; )
;;;
;;; (defun lst->str ( lst del )
;;; ;; © Lee Mac ~ 03.06.10
;;; (if (cdr lst)
;;; (strcat (car lst) del (lst->str (cdr lst) del))
;;; (car lst)
;;; )
;;; )
;;http://forum.dwg.ru/showthread.php?t=8346 ( ָ מןע VLA-SELECT )
;;http://forums.augi.com/showthread.php?p=738077#post738077

;_ֲחנגאוע בכמך BURST'מל ט גמחגנאשאוע סןטסמך ןמכףקוםםץ מבתוךעמג VLA
(defun bg:burst-list (blk / ret ELAST ENAME ENT)
(if (= (type blk) 'VLA-OBJECT)(setq blk (vlax-vla-object->ename blk)))
(Setq ELAST (LASTENT))
(bg:BURST-ONE blk)
(setq ENAME ELAST ret nil)
(While (Setq ENAME (EntNext ENAME))
(setq ENT (entget ENAME))
(if
(and (assoc 60 ENT);_(check Visible dxf code 60) if code 60 set to 1 - object invisible
(= 1 (cdr(assoc 60 ENT)))
)
(VL-CATCH-ALL-APPLY 'entdel (list ENAME))
(setq ret (cons (vlax-ename->vla-object ENAME) ret))
)
)
ret)
;;; blk - Ename בכמךא
;;; level - t all level nil -one level
(defun bg:explode-block ( blk level / adoc csp blk_obj delname)
;_ײטךכ ןמ ןנטלטעטגאל בכמךא
;_ֽומבץמהטל, קעמב גחמנגאע גכמזוםםו בכמךט
;_ blk - Ename בכמךא
;;; level - t all level nil -one level
(if (vlax-write-enabled-p (setq blk_obj (if (= (type blk) 'ENAME)(vlax-ename->vla-object blk) blk)))
(progn
(if
(and (vlax-property-available-p blk_obj 'isdynamicblock)
(= (vla-get-isdynamicblock blk_obj) :vlax-true)
)
(progn
(bg:DynToStatic blk_obj nil) ;_VVA 2015-06-15
;;;(setq blk (entlast)) ;_VVA 2015-06-15
(setq blk (vlax-vla-object->ename blk_obj)) ;_VVA 2015-06-15
;;; (setq delname (cdr(assoc 2 (entget blk))))
)
)
(foreach memb (bg:burst-list Blk)
(cond ((and
level
(= (vla-get-ObjectName memb) "AcDbBlockReference")
)
(bg:explode-block (vlax-vla-object->ename memb) level ));_BURST בכמךאל
(t nil )
)
)
)
)

)

;;ֿנטלונ טסןמכחמגאםט - גסו ןנטלטעטג גחמנגאםםמדמ בכמךא הוכא‏עס ךנאסםל
;;;(defun c:TEST ( / blk blk_obj)
;;;(setq blk (car(entsel "\n׃ךאזטעו בכמך")))
;;; ;_׳טסעטל םאבמנ
;;; (setq *ssRET* nil *ssRET* (ssadd))
;;; (bg:explode-block blk t)
;;; (command "_CHANGE" *ssRET* "" "_P" "_C" 1 "")
;;; (princ))
;;;
;;published by kpblc
;;http://www.arcada.com.ua/forum/viewtopic.php?t=526
;;modyfied and published by VVA
;;http://www.cadtutor.net/forum/showthread.php?t=13295
;|=============================================================================
* װףםךצט "םמנלאכטחאצטט" בכמךמג אךעטגםמדמ פאיכא. ֲ חאגטסטלמסעט מע מעגועא םא
* גמןנמס ך עטןף ByBlock ןנטגמהטעס כטבמ עטן כטםטט, כטבמ גוס כטםטט, כטבמ צגוע,
* כטבמ גסו גלוסעו (ןנט ןףסעמל מעגועו, ע.ו. ןמ ףלמכקאםט‏).
* ־בנאבאעגא‏עס גסו בכמךט, בוח טסךכ‏קוםט.
* ֽו מבנאבאעגא‏עס גםורםטו ססכךט
=============================================================================|;

(defun C:BGBLFIX (/ lst)
;;;; (if (zerop (getvar "PSTYLEMODE"))(vla-put-PlotStyleName obj "ByBlock"))
;;;; CONVERTPSTYLES
(if (eq (getvar "BLOCKEDITOR") 1)
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(bg:msg-Popup
"ֲםטלאםטו"
"ֽומבץמהטלמ גיעט טח נוהאךעמנא בכמךמךא!"
16
)
(bg:msg-Popup
"Attention"
"You must exit the Block Editor!"
16
)
)
(progn
(if (setq lst (bg:blfixdialog))
(bg:blfix lst)
)
)
)
(princ)
)
(defun C:BGLAYDEL ( )(BGLAYDEL nil))

(defun BGLAYDEL ( ask / mdm)
;;;ask - nil חאןנמס t - ףהאכוםטו
;;;׃האכוםטו גךכ‏קוםםץ ט חאלמנמזוםםץ סכמוג ס ןנטלטעטגאלט
(if
(or ask
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(bg:msg-yes-no
"ֲםטלאםטו"
"ֲ הויסעגטעוכםמ ץמעטעו ףהאכטע \nגךכ‏קוםםו ט חאלמנמזוםםו סכמט\n ט מבתוךע םא םטץ?"
)
(bg:msg-yes-no
"Attension"
"You really want to remove \nfrozen and off layers and objects on it?"
)
)
)
(progn
(command "_.UNDO" "_Mark")
(setvar
"CLAYER"
(cdr
(assoc
2
(entmod
(subst
(cons
70
(boole
2
(cdr (assoc 70 (entget (tblobjname "layer" "0"))))
1
) ;_ end of boole
) ;_ end of cons
(assoc 70 (entget (tblobjname "layer" "0")))
(entget (tblobjname "layer" "0"))
) ;_ end of subst
) ;_ end of entmod
) ;_ end of assoc
) ;_ end of cdr
) ;_ end of setvar
(setq mdm (getvar "MODEMACRO"))
(bg:delete-from-layer)
(setvar "MODEMACRO" mdm)
(command "_.Regenall")
(princ "\n*** Command _.UNDO _Back restore your layers")
(princ)
)
)
(princ)
)
;;;BG Color ATTribute
(defun C:BGCATT ( / ss i obj color *error* adoc)
(defun *error* (msg)
(setvar "NOMUTT" 0)
(princ msg)
(bg:layer-status-restore)
(vla-endundomark adoc)(princ))
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
i '-1)
(vla-startundomark adoc)
(if (and (setq color (cond
((and (listp *BG-COLOR*)(assoc 430 *BG-COLOR*))
(acad_truecolordlg (assoc 430 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 420 *BG-COLOR*))
(acad_truecolordlg (assoc 420 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 62 *BG-COLOR*))
(acad_truecolordlg (assoc 62 *BG-COLOR*))
)
(t (acad_truecolordlg 256)) ;_(acad_truecolordlg (assoc 420 color))
)
*BG-COLOR* color)
(setvar "NOMUTT" 1)
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(princ "\nֲבונטעו בכמךט ס אענטבףעאלט :")
(princ "\nSelect Block with Attribute :")
)
(or (setq ss (ssget "_:L" '((0 . "INSERT")(66 . 1))))
(not (setvar "NOMUTT" 0))
(setq ss (ssget "_X" (list '(0 . "INSERT")'(66 . 1)(cons 410 (getvar "CTAB")))))
)
(setvar "NOMUTT" 0)
)
(progn
(bg:layer-status-save)
(repeat (sslength ss)
(setq Obj (vlax-ename->vla-object(ssname ss (setq i (1+ i)))))
(if (and (= (vla-get-objectname Obj) "AcDbBlockReference")
(not (vlax-property-available-p Obj 'path))
)
(foreach att (vlax-invoke Obj 'getattributes)
;;; (vla-put-color att Color) ;;;ZZZ1
(bg:put-color att color)
) ;_ end of foreach
)
)
(setvar "NOMUTT" 0)
(bg:layer-status-restore)
)
)
(vla-endundomark adoc)
(princ)
)

(defun C:BGCBL2 (/ ss i obj color *error* adoc blocks)
(defun *error* (msg)
(setvar "NOMUTT" 0)
(princ msg)
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun

(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blocks (vla-get-blocks adoc)
i '-1)
(vla-startundomark adoc)
(if
(and (setq color (cond
((and (listp *BG-COLOR*)(assoc 430 *BG-COLOR*))
(acad_truecolordlg (assoc 430 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 420 *BG-COLOR*))
(acad_truecolordlg (assoc 420 *BG-COLOR*))
)
((and (listp *BG-COLOR*)(assoc 62 *BG-COLOR*))
(acad_truecolordlg (assoc 62 *BG-COLOR*))
)
(t (acad_truecolordlg 256)) ;_(acad_truecolordlg (assoc 420 color))
)
*BG-COLOR* color)
;;;(setq color '-1)
(setvar "NOMUTT" 1)
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(princ "\nֲבונטעו בכמךט :")
(princ "\nSelect Block :")
) ;_ end of if
(or (setq ss (ssget "_:L" '((0 . "INSERT"))))
(not (setvar "NOMUTT" 0))
(setq
ss (ssget "_X"
(list '(0 . "INSERT") (cons 410 (getvar "CTAB")))
) ;_ end of ssget
) ;_ end of setq
) ;_ end of or
(setvar "NOMUTT" 0)
) ;_ end of and
(progn
(bg:layer-status-save)
(repeat (sslength ss)
(setq Obj (vlax-ename->vla-object (ssname ss (setq i (1+ i)))))
(if (and (= (vla-get-objectname Obj) "AcDbBlockReference")
(not (vlax-property-available-p Obj 'path))
) ;_ end of and
(vlax-for e (vla-item blocks (vla-get-name Obj))
(if (and (= (vla-get-objectname e) "AcDbBlockReference")
(not (vlax-property-available-p e 'path))
) ;_ end of and
(progn
(_pl:block-color blocks e color (vla-get-layers adoc))
(entmod
(append
(vl-remove-if '(lambda(x)(member(car x) '(62 420 430)))
(entget(vlax-vla-object->ename e))
)
color
)
)
)
) ;_ end of if
) ;_ end of vlax-for
) ;_ end of if
) ;_ end of repeat
(setvar "NOMUTT" 0)
(bg:layer-status-restore)
) ;_ end of progn
) ;_ end of if
(vla-endundomark adoc)
(vla-regen adoc acallviewports)
(princ)
) ;_ end of defun
;;; ֲחנגאוע בכמךט, סמסעמשטו טח מהםמדמ ןנטלטעטגא (גמחלמזםמ הנףדמדמ בכמךא)
(defun C:BG1BLEXP ( / count xcount)
(setq count (bg:block-explode-one-item)
xcount (cadr count)
count (car count)
)

(princ "\nExploded ")
(princ count)
(princ " blocks with one element. Found ")
(princ xcount)
(princ " blocks has xclip boundary.")
(princ)
)
;;ֿמךאחאגוע ןמהנוחאםםו בכמךט
(defun C:BGBLXCLIP ( / ss xss i blk)
(setq i '-1 xss (ssadd))
(if (setq ss (ssget "_X" (list '(0 . "INSERT")(cons 410 (getvar "CTAB")))))
(progn
(repeat (sslength ss)
(if (bg:block-GetXclip (vlax-ename->vla-object(setq blk (ssname ss (setq i (1+ i))))))
(ssadd blk xss))
)
(sssetfirst nil xss)
)
)
(princ "\nFound ")
(princ (sslength xss))
(princ " blocks has xclip boundary.")
(setq ss nil xss nil)
(princ)
)

;;;ֲחנגאוע בכמךט 1-דמ ףנמגם, ף ךמעמנץ םוע גטהטלץ אענטבףעמג
(defun C:BGBLEXP1NOATT ( / i ss blk count xcount tmp *error*)
(defun *error* (msg)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "MODEMACRO" "")
(princ msg)
(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
(bg:progress-clear)
(princ)
) ;_ end of defun

(setq i '-1 count 0 xcount 0)
(setq ss (ssget "_I" (list '(0 . "INSERT")'(66 . 0)(cons 410 (getvar "CTAB")))))
(SSSETFIRST)
(command "_.UNDO" "_Mark")
(if (or
ss
(setq ss (ssget "_:L" (list '(0 . "INSERT")'(66 . 0)(cons 410 (getvar "CTAB")))))
)
;(setq ss (ssget "_:L" (list '(0 . "INSERT")'(66 . 0)(cons 410 (getvar "CTAB")))))

(progn
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(if (> (sslength ss) 50)
(bg:progress-init
(strcat "Working ...")
(sslength ss)
) ;_ end of bg:progress-init
) ;_ end of if
(repeat (sslength ss)
(if (and (setq tmp(bg:block-GetXclip (vlax-ename->vla-object(setq blk (ssname ss (setq i (1+ i)))))))
(= 1 (cdr(assoc 71 tmp)))
)
(setq xcount (1+ xcount))
(progn
(bg:progress (setq count (1+ count)))
(bg:explode-block blk nil)
)
)
)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
)
)
(princ "\nExploded ")
(princ count)
(princ " blocks. Found ")
(princ xcount)
(princ " blocks has xclip boundary.")
(if(not(zerop count))(princ "\n*** Command _.UNDO _Back restore your drawing"))
(princ)
)
(defun C:BGBLDYNEXP1 ( / i ss blk count xcount tmp *error*)
(defun *error* (msg)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "MODEMACRO" "")
(princ msg)
(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
(bg:progress-clear)
(princ)
) ;_ end of defun
(setq count 0 xcount 0)
(setq ss (ssget "_I" (list '(0 . "INSERT")(cons 410 (getvar "CTAB")))))
(SSSETFIRST ss)
(command "_.UNDO" "_Mark")
(if (or ss (setq ss (ssget "_:L" (list '(0 . "INSERT")(cons 410 (getvar "CTAB"))))))
(progn
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(if (> (sslength ss) 50)
(bg:progress-init
(strcat "Working ...")
(sslength ss)
) ;_ end of bg:progress-init
) ;_ end of if
(repeat (setq i (sslength ss))
(if (and (setq tmp(bg:block-GetXclip (vlax-ename->vla-object(setq blk (ssname ss (setq i (1- i)))))))
(= 1 (cdr(assoc 71 tmp)))
)
(setq xcount (1+ xcount))
(progn
(bg:progress (setq count (1+ count)))
(if (eq (vla-get-IsDynamicBlock (vlax-ename->vla-object blk)) :vlax-true)
(bg:explode-block blk nil)
)
)
)
)
(bg:progress-clear)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
)
)
(princ "\nTry to explode ")
(princ count)
(princ " blocks. Found ")
(princ xcount)
(princ " blocks has xclip boundary.")
(if(not(zerop count))(princ "\n*** Command _.UNDO _Back restore your drawing"))
(princ)
)
;;;ֲחנגאוע בכמךט 1-דמ ףנמגם, ןנוגנאשא גטהטלו אענטבףע ג עוךסע
(defun C:BGBLEXP1 ( / ret) (setq ret(BGBLEXP nil))
(princ "\nTry to explode ")
(princ (car ret))
(princ " blocks. Found ")
(princ (cadr ret))
(princ " blocks has xclip boundary.")
(if(not(zerop (car ret)))(princ "\n*** Command _.UNDO _Back restore your drawing"))
(princ)

)

;;;ֲחנגאוע בכמך ט גסו בכמךט, גץמהשטו ג םודמ, ןנוגנאשא גטהטלו אענטבףע ג עוךסע
(defun C:BGBLEXP ( / ret )
(setq ret(BGBLEXP t))
(princ "\nTry to explode ")
(princ (car ret))
(princ " blocks. Found ")
(princ (cadr ret))
(princ " blocks has xclip boundary.")
(if(not(zerop (car ret)))(princ "\n*** Command _.UNDO _Back restore your drawing"))
(princ)
)
(defun BGBLEXP ( level / i ss blk count xcount tmp *error*)
;;; t - all nil - one
(defun *error* (msg)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(setvar "MODEMACRO" "")
(princ msg)
(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
(bg:progress-clear)
(princ)
) ;_ end of defun

(setq count 0 xcount 0)
(setq ss (ssget "_I" (list '(0 . "INSERT")(cons 410 (getvar "CTAB")))))
(SSSETFIRST ss)
(command "_.UNDO" "_Mark")
(if (or ss (setq ss (ssget "_:L" (list '(0 . "INSERT")(cons 410 (getvar "CTAB"))))))
(progn
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(if (> (sslength ss) 50)
(bg:progress-init
(strcat "Working ...")
(sslength ss)
) ;_ end of bg:progress-init
) ;_ end of if
(repeat (setq i (sslength ss))
(if (and (setq tmp(bg:block-GetXclip (vlax-ename->vla-object(setq blk (ssname ss (setq i (1- i)))))))
(= 1 (cdr(assoc 71 tmp)))
)
(setq xcount (1+ xcount))
(progn
(bg:progress (setq count (1+ count)))
(bg:explode-block blk level)
)
)
)
(bg:progress-clear)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
)
)
(list count xcount)
)
(defun C:BGCFTSEL( / *error* Doc ss CountField)
;;; http://forum.dwg.ru/showthread.php?t=20190&page=2
(vl-load-com)
(defun *error* (msg)(princ msg)(vla-endundomark doc)(princ))
(setq Doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark Doc)
(if (setq ss (ssget "_:L"))
(progn
(setq CountField 0)
(foreach obj (mapcar (function vlax-ename->vla-object)
(vl-remove-if (function listp)
(mapcar (function cadr) (ssnamex ss))))
(setq CountField (ClearFieldInThisObject Doc Obj CountField))
)
(princ "\nConverting Field in ")(princ CountField)
(princ " text's")
)
)
(vla-endundomark Doc)
(command "_.Regenall")
)

(defun C:BGCFT ()(ConvField->Text t)) ;;;C:CFT
;;; (defun C:CFTAll ()(ConvField->Text nil))
(defun ConvField->Text ( Ask / Doc *error* ClearFieldInAllObjects)
;;; t - Ask user nil - convert
;;; ֺאך גסו ןמכ קונעוזא סנאחף ןנומבנאחמגאע ג עוךסע?
;;; Convert Field to Text
;;; Posted Vladimir Azarko (VVA)
;;; http://forum.dwg.ru/showthread.php?t=20190&page=2
;;; http://forum.dwg.ru/showthread.php?t=20190
(vl-load-com)
(defun *error* (msg)(princ msg)
(bg:layer-status-restore)
(vla-endundomark doc)(princ)
)

(defun ClearFieldInAllObjects (Doc / txtstr tmp txt count CountField mtlist)
(setq CountField 0)
(vlax-for Blk (vla-get-Blocks Doc)
(if (equal (vla-get-IsXref Blk) :vlax-false) ;;;kpbIc http://forum.dwg.ru/showpost.php?p=396910&postcount=30
(progn
(setq count 0
txt (strcat "Changed " (vla-get-name Blk))
)
(grtext -1 txt)
;;; (terpri)(princ "=================== ")(princ txt)
(if (not (wcmatch (vla-get-name Blk) "`*T*")) ;_exclude table
(vlax-for Obj Blk
(setq count (1+ count))
(if (zerop(rem count 10))(grtext -1 (strcat txt " : " (itoa count))))
(setq CountField (ClearFieldInThisObject DOC Obj CountField))
) ;_ end of vlax-for
)
)
) ;_ end of if
) ;_ end of vlax-for
(vl-cmdf "_redrawall")
CountField
)
(setq Doc (vla-get-activedocument (vlax-get-acad-object)))
(bg:layer-status-save)(vla-startundomark Doc)
(if (or (not Ask )
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(bg:msg-yes-no "ֲםטלאםטו"
"ֲסו ןמכ בףהףע ןנומבנאחמגאם ג עוךסע !!!\nֿנמהמכזטע?"
)
(bg:msg-yes-no "Attension"
"All fields will be transformed to the text!!!\nto Continue?"
)
)
)
(progn
(princ "\nConverting Field in ")
(princ (ClearFieldInAllObjects Doc))
(princ " text's")
)
)
(bg:layer-status-restore)(vla-endundomark Doc)
(command "_.Regenall")
(princ)
)
(defun ClearFieldInThisObject ( DOC Obj CountField / att txtstr mtList )
(cond
((and (vlax-write-enabled-p Obj)
(= (vla-get-ObjectName obj) "AcDbBlockReference")
(= (vla-get-HasAttributes obj) :vlax-true)
) ;_ end of and
(foreach att (append (vlax-invoke obj 'Getattributes)
(vlax-invoke obj 'Getconstantattributes)
)

;;;(setq txtstr (vla-get-Textstring att)) ;_Comment VVA 2011-12-09
(setq txtstr (bg:get-TextString (vlax-vla-object->ename att)));_Add VVA 2011-12-09
(vla-put-Textstring att "")
(vla-put-Textstring att txtstr)
(setq Ret t)
(setq CountField (1+ CountField))
) ;_ end of foreach
)
((and (vlax-write-enabled-p Obj)
(vlax-property-available-p Obj 'TextString)
) ;_ end of and
;;; (setq txtstr (vla-get-Textstring Obj)) ;_Comment VVA 2011-12-09
(setq txtstr (bg:get-TextString (vlax-vla-object->ename Obj)));_Add VVA 2011-12-09
(vl-catch-all-apply '(lambda ()(vla-put-Textstring Obj "")(vla-put-Textstring Obj txtstr))) ;;;VVA 07/10/2014
(setq CountField (1+ CountField))
)
((and (vlax-write-enabled-p Obj) ;_Table
(eq (vla-get-ObjectName Obj) "AcDbTable")
)
(and (vlax-property-available-p Obj 'RegenerateTableSuppressed)
(vla-put-RegenerateTableSuppressed Obj :vlax-true)
)
(setq mtlist nil)
(vlax-for item (vla-item(vla-get-blocks DOC)(cdr(assoc 2 (entget(vlax-vla-object->ename obj)))))
(if (and (vlax-write-enabled-p item)
(vlax-property-available-p item 'TextString)
) ;_ end of and
(progn
;; (setq ii (cons item ii))
(setq mtlist
(cons
(list
;;; (vla-get-Handle item)
(mip_MTEXT_Unformat (vla-get-Textstring item))
(bg:get-TextString (vlax-vla-object->ename item))
)
mtlist
)
)
)
)
)
(VL-CATCH-ALL-APPLY
'(lambda (col row / i j tmp lock)
(setq j '-1 )
(repeat row
(setq j (1+ j) i '-1)
(repeat col
(setq i (1+ i))
;;;(vla-GetCellState obj j i)
(if (and (= (vla-GetCellType Obj j i) acTextCell)
(not(zerop(vla-GetFieldId obj j i)))
) ;_Add VVA 2014-11-06
(progn
(setq lock (vla-GetCellState obj j i));_װמנלאע קויךט ;_Add VVA 2015-07-08
(vla-SetCellState obj j i 0) ;_Add VVA 2015-07-08
(if (setq tmp (assoc (mip_MTEXT_Unformat(vla-GetText Obj j i)) mtlist))
(progn
;_(vla-SetText Obj j i "") ;;;_Change VVA 2014-10-30
(vla-SetText Obj j i (cadr tmp))
)
)
(vla-SetCellState obj j i lock)
)
)
(setq CountField (1+ CountField))
)
)
)
(list
(vla-get-Columns Obj)
(vla-get-Rows Obj)
)
)
(and (vlax-property-available-p Obj 'RegenerateTableSuppressed)
(vla-put-RegenerateTableSuppressed Obj :vlax-false)
)
(vla-RecomputeTableBlock Obj :vlax-true)
)
;;; Change VVA 2016-01-04
;;; http://forum.dwg.ru/showthread.php?p=1489832#post1489832
((and (vlax-write-enabled-p Obj) ;_Dimension
(wcmatch (strcase(vla-get-ObjectName Obj)) "*DIMENSION*")
(not(equal(setq att(vla-get-TextOverride Obj)) ""))
)
(setq att (str-str-lst att "\\X") mtList nil)
(vlax-for item (vla-item(vla-get-blocks DOC)(cdr(assoc 2 (entget(vlax-vla-object->ename obj)))))
(if (and (vlax-write-enabled-p item)
(vlax-property-available-p item 'TextString)
) ;_ end of and
(progn
(setq mtList (cons (bg:get-TextString (vlax-vla-object->ename item)) mtList))
;;; (setq txtstr (bg:get-TextString (vlax-vla-object->ename item)))
)
)
)
(setq mtList (reverse mtList))
(if (null mtlist)(setq mtlist att))
;;;ֿנמגונול ךמכטקוסעגמ אבחאצוג נאחלונא
(if (= (length att) 2)
(progn
(if (wcmatch "" (vl-string-trim " " (car att)))
(setq txtstr (strcat "\\X" (cadr mtList)))
(setq txtstr (strcat (car mtList) "\\X" (cadr mtList)))
)
)
(setq txtstr (car mtList))
)
(vla-put-TextOverride Obj "")
(vla-put-TextOverride Obj txtstr)
(setq CountField (1+ CountField))
)
(t nil)
)
CountField
)

(defun C:APPDEL ( / nb nlst lst Rdn adoc )
;;;Mip Util mip-del-Rd
(defun del-XDATA ( en Rdn / elist sub)
(setq elist (entget en (list "*")) sub nil)
(foreach i (cdr (assoc -3 elist))
(if (not(wcmatch (strcase(car i))(strcase Rdn)))
(setq sub (append sub (list i)))
(setq sub (append sub (list(list (car i)))))
))
(setq sub (cons -3 sub)
elist (subst sub (assoc -3 elist) elist)
elist (entmod elist))
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
;_ֿמכףקאול סןטסמך ׀ִ ֿנטלטעטגמג
(if (setq nb (ssget "_X" '((-3 ("*")))))
(progn
(setq nlst nil lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex nb))))
(mapcar '(lambda (e1)
(mapcar '(lambda(rdn)
(if (not(member rdn nlst))
(setq nlst(append nlst (list rdn)))))
(mapcar 'car (car(bg:massoc -3 (entget e1 '("*"))))))
)
lst)
(setq nlst(vl-remove-if '(lambda(x)(wcmatch (strcase x) "ACAD*,ACDB*")) nlst))
(setq Rdn (apply 'strcat (mapcar '(lambda(x)(strcat x ",")) nlst)))
(mapcar '(lambda(x)(del-XDATA x Rdn)) lst)
)
)
(princ "\n׃האכוםםו ׀ִ:")(mapcar 'print nlst)
(princ))

;ֲחמנגאע (נאסקכוםטע) ּֽ-ֱֻ־ֺ
;http://dwg.ru/f/showthread.php?t=11502
(defun C:UX (/ adoc blks u1 n obj objlist uname bname *error* pbname ss)
(defun *error* (msg)
(princ msg)
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun
(defun _copy_unnamed ()
(setq objlist nil
u1 (vla-item blks bname)
n 1
) ;_ end of setq
(vlax-for obj u1
(grtext -1 (strcat "־בנאבאעגא‏ ןנטלטעטג " (itoa n)))
(setq objlist (cons obj objlist))
(setq n (1+ n))
) ;_ end of vlax-for
(setq n (vla-get-insertionpoint obj))

(grtext -1 "ֺמןטנף‏ ןנטלטעטג םאקאכמ ")
(mapcar '(lambda (item)
(vla-move item (vlax-3d-point '(0 0 0)) n)
) ;_ end of lambda
(vlax-safearray->list
(vlax-variant-value
(vla-copyobjects
(vla-get-activedocument (vlax-get-acad-object))
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length objlist)))
) ;_ end of vlax-make-safearray
objlist
) ;_ end of vlax-safearray-fill
) ;_ end of vlax-make-variant
;(vla-get-ModelSpace adoc)
(vla-get-block
(vla-get-activelayout
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-ActiveLayout
) ;_ end of vla-get-block
) ;_ end of vla-copyobjects
) ;_ end of vlax-variant-value
) ;_ end of vlax-safearray->list

) ;_ end of mapcar
(grtext -1 "ֺמןטנף‏ ןנטלטעטג ךמםוצ ")
(entdel uname)
) ;_ end of defun
(vl-load-com)
(bg:layer-status-save)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
) ;_ end of setq
(vla-startundomark adoc)
(if (and (setq uname (car (entsel "\nֲבונט בכמך")))
(setq bname (cdr (assoc 2 (entget uname)))
pbname bname
) ;_ end of setq
(wcmatch bname "`*U*,`*E*")
(setq obj (vlax-ename->vla-object uname))
(or (and (vlax-property-available-p obj "columns")
(vlax-property-available-p obj "rows")
(or (= (vla-get-columns obj) 1)
(and (/= (vla-get-columns obj) 1)
(zerop (vla-get-ColumnSpacing obj))
)
)
(or (= (vla-get-rows obj) 1)
(and (/= (vla-get-rows obj) 1)
(zerop (vla-get-RowSpacing obj))
)
)
) ;_ end of and
(and (not (vlax-property-available-p obj "columns"))
(not (vlax-property-available-p obj "rows"))
) ;_ end of and
) ;_ end of or
) ;_ end of and
(progn
(_copy_unnamed)

(vl-catch-all-apply
'(lambda ()
(if
(and
(setq uname (entlast))
(setq bname (cdr (assoc 2 (entget uname))))
(wcmatch bname "`*U*")
(setq obj (vlax-ename->vla-object uname))
(or (and (vlax-property-available-p obj "columns")
(vlax-property-available-p obj "rows")
(or (= (vla-get-columns obj) 1)
(and (/= (vla-get-columns obj) 1)
(zerop (vla-get-ColumnSpacing obj))
)
)
(or (= (vla-get-rows obj) 1)
(and (/= (vla-get-rows obj) 1)
(zerop (vla-get-RowSpacing obj))
)
)
) ;_ end of and
(and (not (vlax-property-available-p obj "columns"))
(not (vlax-property-available-p obj "rows"))
) ;_ end of and
) ;_ end of or
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(bg:msg-yes-no
"ֲםטלאםטו"
(strcat
"ֿמץמזו, סףשוסעףוע גכמזוםםמסע אםמםטלםץ בכמךמג!"
"\nֿנוההףשוו טל "
pbname
"\nׂוךףשוו טל "
bname
"\nֿנמהמכזטע גחנגאע אםמםטלםו בכמךט?"
) ;_ end of strcat
) ;_ end of bg:msg-yes-no
(bg:msg-yes-no
"Attension"
(strcat
"There nested anonymous blocks!"
"\nLast name "
pbname
"\nCurrent name "
bname
"\nContinue to explode anonymous blocks?"
) ;_ end of strcat
) ;_ end of bg:msg-yes-no
) ;_ end of if
) ;_ end of and
(progn
(while
(and
(setq uname (entlast))
(setq bname (cdr (assoc 2 (entget uname))))
(wcmatch bname "`*U*")
(not (eq pbname bname))
(setq obj (vlax-ename->vla-object uname))
(or
(and (vlax-property-available-p obj "columns")
(vlax-property-available-p obj "rows")
(or (= (vla-get-columns obj) 1)
(and (/= (vla-get-columns obj) 1)
(zerop (vla-get-columnspacing obj))
) ;_ end of and
) ;_ end of or
(or (= (vla-get-rows obj) 1)
(and (/= (vla-get-rows obj) 1)
(zerop (vla-get-rowspacing obj))
) ;_ end of and
) ;_ end of or
) ;_ end of and
(and (not (vlax-property-available-p obj "columns"))
(not (vlax-property-available-p obj "rows"))
) ;_ end of and
) ;_ end of or
;;;(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
;;; (bg:msg-yes-no
;;; "ֲםטלאםטו"
;;; (strcat
;;; "ֿמץמזו, סףשוסעףוע גכמזוםםמסע אםמםטלםץ בכמךמג!"
;;; "\nֿנוההףשוו טל "
;;; pbname
;;; "\nׂוךףשוו טל "
;;; bname
;;; "\nֿנמהמכזטע גחנגאע אםמםטלםו בכמךט?"
;;; ) ;_ end of strcat
;;; ) ;_ end of bg:msg-yes-no
;;; (bg:msg-yes-no
;;; "Attension"
;;; (strcat
;;; "ֿמץמזו, סףשוסעףוע גכמזוםםמסע אםמםטלםץ בכמךמג!"
;;; "\nֿנוההףשוו טל "
;;; pbname
;;; "\nׂוךףשוו טל "
;;; bname
;;; "\nֿנמהמכזטע גחנגאע אםמםטלםו בכמךט?"
;;; ) ;_ end of strcat
;;; ) ;_ end of bg:msg-yes-no
;;; )

) ;_ end of and
(vla-endundomark adoc)
(setq pbname bname)
(_copy_unnamed)
(vla-startundomark adoc)
) ;_ end of while
(while (> (getvar "CMDACTIVE") 0) (command))
(if (setq ss (ssget "_x" (list (cons 0 "WIPEOUT")(cons 410 (getvar "ctab")))))
(command "_draworder" ss "" "_b")
)
)
) ;_ end of if
) ;_ end of lambda
) ;_ end of VL-CATCH-ALL-APPLY
) ;_ end of progn
) ;_ end of if
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun
(defun bg:objectidtoobject (obj id)
;;; ֺמה םטזו חאךמלוםעטנמגאם
;;; ׁגחאםמ סעול, קעמ ג 2015 ְגעמךאהו ףהאכום לועמה objectidtoobject32
;;; ׳טעאע ןמכםמסע‏ http://help.autodesk.com/view/ACD/2015/ENU/?guid=GUID-6FEDBCCA-91D0-4782-AE5A-49BD4384FD8C
;;

;;; (if (> (vl-string-search "x64" (getvar "platform")) 0)
;;; (if (vlax-method-applicable-p obj 'objectidtoobject32)(vla-objectidtoobject32 obj id)(vla-objectidtoobject obj id))
;;; (vla-objectidtoobject obj id)
;;; ) ;_ end of if
(if (vlax-method-applicable-p obj 'objectidtoobject32)
(vla-objectidtoobject32 obj id)
(vla-objectidtoobject obj id)
)
) ;_ end of defun
(defun C:M2B ( / adoc blks u1 n obj objlist uname bname unnamed_block cpo tmp_blk ss lst)
;;;Convert Minsert block To Block
;;; Posted Vladimir Azarko (VVA)
;;; http://forum.dwg.ru/showthread.php?t=11502&page=3(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
) ;_ end of setq
(vla-AuditInfo adoc :vlax-true)
(vla-startundomark adoc)
(if (setq ss (ssget "_:L" '((0 . "INSERT")
(-4 . "")(70 . 1)
(-4 . ">")(71 . 1)
(-4 . "OR>")
)))
(progn
(repeat (setq n (sslength ss)) ;_ end setq
(setq lst (cons (ssname ss (setq n (1- n))) lst))
) ;_ end
(setq ss nil n 0)
(foreach uname lst
(grtext -1 (strcat "Working " (itoa (setq n (1+ n)))))
(setq bname (cdr(assoc 2 (entget uname))))
(setq u1 (vla-item blks bname))
(setq obj (vlax-ename->vla-object uname) objlist nil)
(vlax-for item u1 (setq objlist (cons item objlist)))
(setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0 0 0)) "*U"))
(setq cpo (vla-copyobjects adoc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length objlist)))
) ;_ end of vlax-make-safearray
objlist
) ;_ end of vlax-safearray-fill
) ;_ end of vlax-make-variant
;(vla-get-ModelSpace adoc)
unnamed_block
)
)
(setq tmp_blk (vla-insertblock
(bg:objectidtoobject adoc (vla-get-ownerid obj))
(vla-get-InsertionPoint obj)
(vla-get-name unnamed_block)
(vla-get-xscalefactor obj)(vla-get-yscalefactor obj)
(vla-get-zscalefactor obj)
;(vla-get-rotation obj)
0
)
)
(setq cpo (vla-ArrayRectangular tmp_blk (vla-get-rows obj)(vla-get-columns obj) 1 (vla-get-RowSpacing obj)(vla-get-ColumnSpacing obj) 0))
(setq cpo (vlax-safearray->list(vlax-variant-value cpo)))
(setq cpo (cons tmp_blk cpo))
(foreach item cpo
(vla-rotate item (vla-get-InsertionPoint obj) (vla-get-rotation obj))
)
(entdel uname)
)
(princ "Converting ")(princ n)(princ " minsert blocks")
)
)
(vla-endundomark adoc)
(vl-cmdf "_.Redraw")
(princ)
)
(defun C:U2B (/ adoc blks u1 n obj
objlist uname bname *error* bnameNew tmp_blk
)
;;; Unnamed to Block
(defun *error* (msg)
(princ msg)
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun
(vl-load-com)
(bg:layer-status-save)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
) ;_ end of setq
(vla-startundomark adoc)
(if
(and (setq uname (car (entsel (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\nֲבונט בכמך: " "\nSelect block: "))))
(wcmatch (setq bname (cdr (assoc 2 (entget uname)))) "`*U*,`*X*,`*E*")
(setq obj (vlax-ename->vla-object uname))
(or (and (vlax-property-available-p obj "columns")
(vlax-property-available-p obj "rows")
(= (vla-get-columns obj) 1)
(= (vla-get-rows obj) 1)
) ;_ end of and
(and (not (vlax-property-available-p obj "columns"))
(not (vlax-property-available-p obj "rows"))
) ;_ end of and
) ;_ end of or
(setq bnameNew (getstring (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\nָל בכמךא: " "\nNew block name: ")))
(or
(while (or (not (snvalid bnameNew))
(member (strcase bnameNew) (tablelist "BLOCK"))
) ;_ end of or
(alert (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\nֽוהמןףסעטלמו טל בכמךא" "Incorrect block name"))
(setq bnameNew (getstring (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\nָל בכמךא: " "\nNew block name: ")))
) ;_ end of while
t)
) ;_ end of and
(progn
(setq unnamed_block
(vla-add (vla-get-blocks adoc)
(vlax-3d-point '(0 0 0))
bnameNew
) ;_ end of vla-add
) ;_ end of setq
(setq u1 (vla-item blks bname)
n 1
) ;_ end of setq
(vlax-for item u1
(grtext -1 (strcat "Working ... item " (itoa n)))
(setq objlist (cons item objlist))
(setq n (1+ n))
) ;_ end of vlax-for
(setq n (vlax-3d-point(trans(vlax-safearray->list(vlax-variant-value(vla-get-insertionpoint obj))) 0 uname)))
;;; (setq n (vlax-3d-point(trans (vlax-safearray->list(vlax-variant-value n)) uname 0)))
(grtext -1 "Coping item. Begin ")
(vla-copyobjects
adoc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length objlist)))
) ;_ end of vlax-make-safearray
objlist
) ;_ end of vlax-safearray-fill
) ;_ end of vlax-make-variant
;(vla-get-ModelSpace adoc)
unnamed_block
) ;_ end of
(grtext -1 "Coping item. End ")
(setq
tmp_blk (vla-insertblock
(bg:objectidtoobject adoc (vla-get-ownerid obj))
;(vla-get-InsertionPoint obj)
n
(vla-get-name unnamed_block)
(vla-get-xscalefactor obj)
(vla-get-yscalefactor obj)
(vla-get-zscalefactor obj)
(vla-get-rotation obj)
) ;_ end of vla-insertblock
) ;_ end of setq
(mapcar
'(lambda (x y) (vlax-put-property tmp_blk x y))
'(Linetype LineWeight Color Layer)
(mapcar
'(lambda (x)
(vlax-get-property obj x))
'(Linetype LineWeight Color Layer)))
(vla-put-Normal tmp_blk (vla-get-Normal obj))
(entdel uname)
) ;_ end of progn
) ;_ end of if
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun

(defun C:U2BM (/ ss adoc blks pat u1 i n obj
objlist uname bname *error* bnameNew tmp_blk
)
;;; Unnamed to Block Multiple
(defun *error* (msg)
(princ msg)
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun
(vl-load-com)
(bg:layer-status-save)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
) ;_ end of setq
(vla-startundomark adoc)
(setq pat "U2B-")
(if (setq ss (ssget '((0 . "INSERT"))))
(repeat (setq i (sslength ss))
(setq uname (ssname ss (setq i (1- i))))
(if
(and (wcmatch (setq bname (cdr (assoc 2 (entget uname)))) "`*U*,`*X*")
(setq obj (vlax-ename->vla-object uname))
(eq
(cond
((and (vlax-property-available-p obj 'isdynamicblock)
(= (vla-get-isdynamicblock obj) :vlax-true)
) ;_ end of and
(vla-get-effectivename obj)
)
(t (vla-get-name obj))
)
bname
)
(or (and (vlax-property-available-p obj "columns")
(vlax-property-available-p obj "rows")
(= (vla-get-columns (vlax-ename->vla-object uname)) 1)
(= (vla-get-rows (vlax-ename->vla-object uname)) 1)
) ;_ end of and
(and (not (vlax-property-available-p obj "columns"))
(not (vlax-property-available-p obj "rows"))
) ;_ end of and
) ;_ end of or
(setq n 0 bnameNew (strcat pat (substr bname 2)))
(or
(while (or (not (snvalid bnameNew))
(member (strcase bnameNew) (tablelist "BLOCK"))
) ;_ end of or
(setq bnameNew (strcat pat (substr bname 2) "-" (itoa (setq n (1+ n)))))
) ;_ end of while
t)
) ;_ end of and
(progn
(setq unnamed_block
(vla-add (vla-get-blocks adoc)
(vlax-3d-point '(0 0 0))
bnameNew
) ;_ end of vla-add
) ;_ end of setq
(setq u1 (vla-item blks bname)
n 1
objlist nil
) ;_ end of setq
(vlax-for item u1
(grtext -1 (strcat "Working ... item " (itoa n)))
(setq objlist (cons item objlist))
(setq n (1+ n))
) ;_ end of vlax-for
;;; (setq n (vla-get-insertionpoint (vlax-ename->vla-object uname)))
(setq n (vlax-3d-point(trans(vlax-safearray->list(vlax-variant-value(vla-get-insertionpoint obj))) 0 uname)))
(grtext -1 "Coping item. Begin ... ")
(vla-copyobjects
adoc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length objlist)))
) ;_ end of vlax-make-safearray
objlist
) ;_ end of vlax-safearray-fill
) ;_ end of vlax-make-variant
;(vla-get-ModelSpace adoc)
unnamed_block
) ;_ end of
(grtext -1 "Coping item. End ")
(setq
tmp_blk (vla-insertblock
(bg:objectidtoobject adoc (vla-get-ownerid obj))
;(vla-get-InsertionPoint obj)
n
(vla-get-name unnamed_block)
(vla-get-xscalefactor obj)
(vla-get-yscalefactor obj)
(vla-get-zscalefactor obj)
(vla-get-rotation obj)
) ;_ end of vla-insertblock
) ;_ end of setq
(mapcar
'(lambda (x y) (vlax-put-property tmp_blk x y))
'(Linetype LineWeight Color Layer)
(mapcar
'(lambda (x)
(vlax-get-property obj x))
'(Linetype LineWeight Color Layer)))
(vla-put-Normal tmp_blk (vla-get-Normal obj))
(entdel uname)
) ;_ end of progn
) ;_ end of if
)
)
(bg:layer-status-restore)
(vla-endundomark adoc)
(princ)
) ;_ end of defun

;;;Convert Minsert block To Block
;;;http://dwg.ru/f/showthread.php?t=11502&page=3
(defun C:M2U ( / adoc blks u1 n obj objlist uname bname unnamed_block cpo tmp_blk ss lst)
(vl-load-com)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
) ;_ end of setq
(vla-startundomark adoc)

(if (setq ss (ssget "_:L" '((0 . "INSERT")(-4 . ">")(70 . 1)(71 . 1))))
(progn
(repeat (setq n (sslength ss)) ;_ end setq
(setq lst (cons (ssname ss (setq n (1- n))) lst))
) ;_ end
(setq ss nil n 0)
(foreach uname lst
(grtext -1 (strcat "Working " (itoa (setq n (1+ n)))))
(setq bname (cdr(assoc 2 (entget uname))))
(setq u1 (vla-item blks bname))
(setq obj (vlax-ename->vla-object uname) objlist nil)
(vlax-for item u1 (setq objlist (cons item objlist)))
(setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0 0 0)) "*U"))
(setq cpo (vla-copyobjects adoc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length objlist)))
) ;_ end of vlax-make-safearray
objlist
) ;_ end of vlax-safearray-fill
) ;_ end of vlax-make-variant
;(vla-get-ModelSpace adoc)
unnamed_block
)
)
(setq tmp_blk (vla-insertblock
(bg:objectidtoobject adoc (vla-get-ownerid obj))
(vla-get-InsertionPoint obj)
(vla-get-name unnamed_block)
(vla-get-xscalefactor obj)(vla-get-yscalefactor obj)
(vla-get-zscalefactor obj)
;(vla-get-rotation obj)
0
)
)
(setq cpo (vla-ArrayRectangular tmp_blk (vla-get-rows obj)(vla-get-columns obj) 1 (vla-get-RowSpacing obj)(vla-get-ColumnSpacing obj) 0))
(setq cpo (vlax-safearray->list(vlax-variant-value cpo)))
(setq cpo (cons tmp_blk cpo))
(foreach item cpo
(vla-rotate item (vla-get-InsertionPoint obj) (vla-get-rotation obj))
)
(entdel uname)
)
(princ "Converting ")(princ n)(princ " minsert blocks")
)
)
(vla-endundomark adoc)
(vl-cmdf "_.Redraw")
(princ)
)
(defun C:BGCOLORXREF (/ doc col xreflist)
(vl-load-com)
;;; (alert
;;; "\This lisp change color xref\nONLY ON A CURRENT SESSION"
;;; ) ;_ end of alert
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(bg:layer-status-save)
(vlax-for item (vla-get-Blocks doc)
(if (= (vla-get-IsXref item) :vlax-true)
(setq xreflist (cons (vla-get-name item) xreflist))
)
)
(if (and xreflist
(setq xreflist (_dwgru-get-user-dcl "ֲבונטעו ססכךט " (acad_strlsort xreflist) t))
(setq col (acad_colordlg 7 t))
)
(ChangeXrefAllObjectsColor doc col xreflist) ;_ col — color number
) ;_ end of if
(bg:layer-status-restore)
(vla-endundomark doc)
(princ)
) ;_ end of defun
;;; ************************************************************************
;;; * ֱטבכטמעוךא DWGruLispLib Copyright ©2008 DWGru Programmers Group
;;; *
;;; * _dwgru-get-user-dcl (ֺאםהטהאע)
;;; *
;;; * ַאןנמס חםאקוםט ף ןמכחמגאעוכ קונוח הטאכמדמגמו מךםמ
;;; *
;;; *
;;; * 26/01/2008 ֲונסט 0002. ׀והאךצט ֲכאהטלטנ ְחאנךמ (VVA)
;;; - ֲץמה ןמ הגמיםמלף ךכטךף, וסכט חאןנושום לםמזוסעגוםםי גבמנ (multi-nil)
;;; - ־בנאבמעךא םוסךמכךטץ ךמכמםמך
;;; * 21/01/2008 ֲונסט 0001. ׀והאךצט ֲכאהטלטנ ְחאנךמ (VVA)
;;; ************************************************************************

;;; ************************************************************************
;;; * Library DWGruLispLib Copyright © 2008 DWGru Programmers Group
;;; *
;;; * _dwgru-get-user-dcl (Candidate)
;;; *
;;; * Inquiry of value at the user through a dialogue window
;;; *
;;; *
;;; * 26/01/2008 Version 0002. Edition Vladimir Azarko (VVA)
;;; - the Output on double a clique if the plural choice (multi-nil) is forbidden
;;; - Processing of several columns
;;; * 21/01/2008 Version 0001. Edition Vladimir Azarko (VVA)

(defun _DWGRU-GET-USER-DCL (ZAGL INFO-LIST MULTI
/ FL RET
DCL_ID MAXROW MAX_COUNT_COL
COUNT_COL I LISTBOX_HEIGHT
LST _LOC_FINISH _LOC_CLEAR
NCOL tmp
)
;|
* ENGLISH
* Inquiry of value at the user through a dialogue window
* Dialogue is formed to "strike"
* the Quantity of lines on page without scrolling is set by variable MAXROW.
* It is necessary to remember, that number MAXROW increases on 3.
* the Maximum quantity of columns is set by variable MAX_COUNT_COL
* It is published
http://dwg.ru/f/showthread.php?p=203746#post203746
* Parameters of a call:
zagl - heading of a window [String]
info-list - the list of line values [List of String]
multi - t - the plural choice is resolved, nil-is not present

* Returns:
The list of the chosen lines or nil - a cancelling
* the Example
(_dwgru-get-user-dcl " Specify a variant " ' ("First" "Second" "Third") nil); _-> ("First")
(_dwgru-get-user-dcl " Specify a variant " ' ("First" "Second" "Third") t); _-> ("First" "Second ")
(_dwgru-get-user-dcl " Specify a variant "
(progn (setq i 0 lst nil) (repeat 205 (setq lst (cons (strcat "ַםאקוםטו-" (itoa (setq i (1 + i)))) lst))) (reverse lst)) nil)
(_dwgru-get-user-dcl " Specify a variant, using CTRL and SHIFT for a choice "
(progn (setq i 0 lst nil) (repeat 205 (setq lst (cons (strcat "ַםאקוםטו-" (itoa (setq i (1 + i)))) lst))) (reverse lst)) t)
|;
;|
* RUS
* ַאןנמס חםאקוםט ף ןמכחמגאעוכ קונוח הטאכמדמגמו מךםמ
* ִטאכמד פמנלטנףועס "םאכועף"
* ֺמכטקוסעגמ סענמך םא סענאםטצף בוח סךנמככטםדא חאהאועס ןונולוםםמי MAXROW.
* ֽומבץמהטלמ ןמלםטע, קעמ קטסכמ MAXROW ףגוכטקטגאועס םא 3.
* ּאךסטלאכםמו ךמכטקוסעגמ ךמכמםמך חאהאועס ןונולוםםמי MAX_COUNT_COL
* ־ןףבכטךמגאםא
http://dwg.ru/f/showthread.php?p=203746#post203746
* ֿאנאלוענ גחמגא:
zagl - חאדמכמגמך מךםא [String]
info-list - סןטסמך סענמךמגץ חםאקוםטי [List of String]
multi - t - נאחנורום לםמזוסעגוםםי גבמנ, nil- םוע

* ֲמחגנאשאוע:
ׁןטסמך גבנאםםץ סענמך טכט nil - מעלוםא
* ֿנטלונ
(_dwgru-get-user-dcl "׃ךאזטעו גאנטאםע" '("ֿונגי" "ֲעמנמי" "ׂנועטי") nil) ;_->("ֿונגי")
(_dwgru-get-user-dcl "׃ךאזטעו גאנטאםע" '("ֿונגי" "ֲעמנמי" "ׂנועטי") t) ;_->("ֿונגי" "ֲעמנמי")
(_dwgru-get-user-dcl "׃ךאזטעו גאנטאםע"
(progn (setq i 0 lst nil)(repeat 205 (setq lst (cons (strcat "ַםאקוםטו-" (itoa (setq i (1+ i)))) lst)))(reverse lst)) nil)
(_dwgru-get-user-dcl "׃ךאזטעו גאנטאםע, טסןמכחף CTRL ט SHIFT הכ גבמנא"
(progn (setq i 0 lst nil)(repeat 205 (setq lst (cons (strcat "ַםאקוםטו-" (itoa (setq i (1+ i)))) lst)))(reverse lst)) t)
|;
;_ ===== ֺ־ְֽֽׁׂׂ ============

(setq MAXROW 40) ;_לאךc. ךמכ-גמ סענמך בוח סךנמככטםדא (ֺ םולף האכרו המבאגטעס ושו 3 סענמקךט)
;_ max lines without scrolling (To it 3 more lines further will be added)
(setq MAX_COUNT_COL 5) ;_לאךסטלאכםמו ךמכטקוסעגמ ךמכמםמך
;_ ; _ a maximum quantity of columns
;;============== ֻמךאכםו פףםצךצטט START==================
;;============== Local functions START========================

(defun _LOC_FINISH ()
(setq I 0
RET NIL
) ;_ end ofsetq
(repeat COUNT_COL
(setq I (1+ I))
(setq RET (cons (cons I (get_tile (strcat "info" (itoa I)))) RET))
) ;_ end ofrepeat
(setq RET (reverse RET))
(done_dialog 1)
) ;_ end ofdefun
(defun _LOC_ERR-TILE (what)
;;;what - string or nil
(if what
(set_tile "error" what)
(if MULTI
(set_tile "error"
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"ָסןמכחףיעו CTRL ט SHIFT הכ גבמנא"
"Use CTRL and SHIFT for a choicet"
) ;_ end ofif
) ;_ end ofset_tile
(set_tile "error"
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"ּמזםמ גבטנאע הגמיםל שוכקךמל"
"It is possible to choose double click"
) ;_ end ofif
) ;_ end ofset_tile
) ;_ end ofif
)
)
(defun _LOC_CLEAR (NOMER)
(setq I 0)
(repeat COUNT_COL
(setq I (1+ I))
(if (/= I NOMER)
(progn
(start_list (strcat "info" (itoa I)))
(mapcar 'add_list (nth (1- I) LST))
(end_list)
) ;_ end ofprogn
) ;_ end ofif
) ;_ end ofrepeat
) ;_ end ofdefun

;;;==================== ֻמךאכםו פףםצךצטט END ==================================
;;;==================== Local functions END ==================================

;;;==================== MAIN PART ===============================================

(if (null ZAGL)
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(setq ZAGL "ֲבמנ")
(setq ZAGL "Select")
) ;_ end ofif
) ;_ end if
(if (zerop (rem (length INFO-LIST) MAXROW)) ;_ײוכמו ךמכטקוסעגמ סעמכבצמג
(setq COUNT_COL (/ (length INFO-LIST) MAXROW)) ;_ֵדמ ט מסעאגכול
(setq COUNT_COL (1+ (fix (/ (length INFO-LIST) MAXROW 1.0)))) ;_ֱונול בכטזאירוו צוכמו
) ;_ end ofif
(if (> COUNT_COL MAX_COUNT_COL)
(setq COUNT_COL MAX_COUNT_COL)
) ;_־דנאםטקטגאול max ךמכטקוסעגמל
(setq LISTBOX_HEIGHT (+ 3 MAXROW)) ;_ המבאגכול 3 סענמקךט הכ ךנאסמע ט הכ טסךכ‏קוםט ןמדנאםטקםמדמ סךנמככטםדא
;_ We add 3 lines for appearance and for exception boundary scroll
(if (and (= COUNT_COL 1) (<= (length INFO-LIST) MAXROW))
(setq LISTBOX_HEIGHT (+ 3 (length INFO-LIST)))
) ;_ end ofif
(setq I 0)
(setq FL (vl-filename-mktemp "dwgru" NIL ".dcl"))
(setq RET (open FL "w")
LST NIL
) ;_ end ofsetq
(mapcar '(lambda (X) (write-line X RET))
(append (list "dwgru_get_user : dialog { "
(strcat "label=\"" ZAGL "\";")
": boxed_row {"
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"label = \"ַםאקוםטו\";"
"label = \"Value\";"
) ;_ end ofif
) ;_ end oflist
(repeat COUNT_COL
(setq LST
(append
LST
(list
" :list_box {"
"alignment=top ;"
(if MULTI
"multiple_select = true ;"
"multiple_select = false ;"
) ;_ end ofif
(strcat
"width="
(itoa
((lambda(len)
(setq len
(cond ((and
(< COUNT_COL 3)
( COUNT_COL 2)
(< len 73)
)
len
)
(t 41)
)
)
(if (< len 25) 25 len)
)
(apply 'max (mapcar 'strlen info-list))
)
)
";"
)
(strcat "height= " (itoa LISTBOX_HEIGHT) " ;")
"is_tab_stop = false ;"
(strcat "key = \"info" (itoa (setq I (1+ I))) "\";}")
) ;_ end oflist
) ;_ end ofappend
) ;_ end ofsetq
) ;_ end ofrepeat
(list
"}"
":row{"
"ok_cancel_err;}}"
) ;_ end oflist
) ;_ end of list
) ;_ end of mapcar
(setq RET (close RET))
(if (and (null (minusp (setq DCL_ID (load_dialog FL))))
(new_dialog "dwgru_get_user" DCL_ID)
) ;_ end and
(progn
(setq LST INFO-LIST)
((lambda (/ RET1 BUF ITM)

(repeat (1- COUNT_COL)
(setq I '-1)
(while (and (setq ITM (car LST))
(< (setq I (1+ I)) MAXROW)
) ;_ end ofand
(setq BUF (cons ITM BUF)
LST (cdr LST)
) ;_ end ofsetq
) ;_ end ofwhile
(setq RET1 (cons (reverse BUF) RET1)
BUF NIL
) ;_ end ofsetq
) ;_ end ofrepeat
(setq RET RET1)
) ;_ end oflambda
)
(if LST
(setq RET (cons LST RET))
) ;_ end ofif
(setq LST (reverse RET))
(setq I 0)
(mapcar '(lambda (THIS_LIST)
(if (>>--------- comment VVA 2011-04-28
;;; (setq txtstr
;;; (if (vlax-method-applicable-p Obj 'FieldCode)
;;; (vla-FieldCode Obj)
;;; (vlax-get-property Obj 'TextString))
;;; )
;;; <<>>--------- ADD VVA 2011-04-28
(setq txtstr (bg:FieldCode (vlax-vla-object->ename Obj)))
;;; <<list
(vlax-variant-value (vla-GetAttributes obj))
) ;_ end of vlax-safearray->list
(if (and (vlax-write-enabled-p att)
(vlax-property-available-p att 'Color)
) ;_ end of and
(VL-CATCH-ALL-APPLY 'vla-put-Color (list att Color)) ;_(vla-put-Color att Color)
) ;_ end of if
) ;_ end of foreach
)
)
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
(wcmatch (vla-get-Objectname Obj) "*Dimension*,AcDb*Leader")
) ;_ end of and
(progn
(vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))
(vl-catch-all-apply 'vla-put-TextColor (list Obj Color))
(vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))
(if (vlax-property-available-p Obj 'LeaderLineColor)
(progn
(setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."
(substr (getvar "ACADVER") 1 2))))
(vla-put-colorindex tmp Color)
(vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))
)
)
) ;_ end of progn
) ;_ end of if
) ;_ end of vlax-for
)
(t nil)
) ;_cond
) ;_ end of vlax-for
;;;־בנאבמעךא סעטכוי לףכעטכטםטי

(vla-regen Doc acAllViewports)
;; (vl-cmdf "_regenall")
) ;_ end of defun
(defun bg:hatch-delete-form-Block ( Blk )
;;; Blk -vla-object "AcDbBlockTableRecord"
(if (= (vla-get-IsXref Blk) :vlax-false)
(progn
(if (> (vla-get-count Blk) 100)
(bg:progress-init
(strcat (vla-get-name Blk) " :")
(vla-get-count Blk)
) ;_ end of bg:progress-init
(progn
(setvar "MODEMACRO" (vla-get-name Blk))
) ;_ end of progn
) ;_ end of if
(vlax-for Obj Blk
(if (and
(= (vla-get-ObjectName Obj) "AcDbHatch")
(vlax-write-enabled-p Obj)
)
(vl-catch-all-apply 'vla-delete (list Obj))
) ;_ end of if
) ;_ end of vlax-for
(bg:progress-clear)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(defun bg:hatch-delete ( adoc IgnoreLockLayer / *error*)
;;; adoc - active document (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))
;;; IgnoreLockLayer -t - ignore nil - not
(defun *error* (msg)
(setvar "MODEMACRO" "")
(princ msg)
(vla-regen aDOC acactiveviewport)
(bg:progress-clear)
(bg:layer-status-restore)
(princ)
) ;_ end of defun

;;; (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))
(and IgnoreLockLayer
(bg:layer-status-save)
)
(vlax-for Blk (vla-get-Blocks aDOC)
(bg:hatch-delete-form-Block Blk)
)
(bg:layer-status-restore)
(vla-regen aDOC acActiveViewport)
(princ)
) ;_ end of defun
(defun C:BGHATCHDEL ()
(bg:hatch-delete (vla-get-activedocument (vlax-get-acad-object))
(bg:msg-yes-no
(if (= (getvar "DWGCODEPAGE") "ANSI_1251") "׃האכוםטו ״ענטץמגךט" "Remove the hatch")
(if (= (getvar "DWGCODEPAGE") "ANSI_1251") "׃האכע רענטץמגךף ס \nחאבכמךטנמגאםםץ טכט חאלמנמזוםםץ סכמוג?" "Remove hatch from \n locked or frozen layers?")
)
)
)

;;;(defun c:erase-hatch (/ adoc)
;;; (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
;;; (vlax-for blk_def (vla-get-blocks adoc)
;;; (if (equal (vla-get-isxref blk_def) :vlax-false)
;;; (vlax-for ent blk_def
;;; (if (= (vla-get-objectname ent) "AcDbHatch")
;;; (vl-catch-all-apply
;;; (function
;;; (lambda ()
;;; (vla-erase ent)
;;; ) ;_ end of lambda
;;; ) ;_ end of function
;;; ) ;_ end of vl-catch-all-apply
;;; ) ;_ end of if
;;; ) ;_ end of vlax-for
;;; ) ;_ end of if
;;; ) ;_ end of vlax-for
;;; (vla-endundomark adoc)
;;; (princ)
;;; ) ;_ end of defun

(defun bg:Color-to-ACIcolor (/ txt count *error*)
(defun *error* (msg)
(princ msg)
(bg:layer-status-restore)
(princ)
) ;_ end of defun
(bg:layer-status-save)
(vlax-for Blk (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-blocks
(setq count 0)
(grtext -1
(setq txt
(strcat "Inspecting objects: "
(vla-get-name Blk)
)
)
) ;_ end of grtext
(if (or
(not(wcmatch (vla-get-name Blk) "*|*"))
(eq (vla-get-isxref Blk) :vlax-false)
)
(progn
(vlax-for Obj Blk
(setq count (1+ count))
(if (zerop (rem count 10))
(grtext -1 (strcat txt " : " (itoa count)))
)
(if (and (vlax-write-enabled-p Obj)
(vlax-property-available-p Obj 'Color)
)
(vla-put-color Obj (vla-get-color Obj))
)
) ;_ end of vlax-for
) ;_ end of progn
(progn
(princ "\nSkip=")(princ (vla-get-name Blk))
)
) ;_ end of if
) ;_ end of vlax-for
(vlax-for Lay (vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
)
(vla-put-color Lay (vla-get-color Lay))
)
(bg:layer-status-restore)
)
(defun C:BGRGB2ACI ( )
(bg:Color-to-ACIcolor)
(command "_.Regenall")
(princ)
)
;|
;;;http://www.cadtutor.net/forum/showthread.php?t=533&page=8
(defun c:blccA ()
;;;blccA - BLock Change Color Area
(pl:block-colorA)
(princ)
) ;_ end of defun
;;;get from Alaspher http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
(defun pl:block-colorA (/ adoc blocks color ins lays ss lst)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blocks (vla-get-blocks adoc)
lays (vla-get-layers adoc)
) ;_ end of setq
(if (and (setq color (acad_colordlg 256))
(setq ss (ssget '((0 . "INSERT"))))
(progn
(repeat (setq ins (sslength ss)) ;_ end setq
(setq lst (cons (ssname ss (setq ins (1- ins))) lst))
) ;_ end repeat
lst
) ;_ end of progn
) ;_ end of and
(progn
(vla-startundomark adoc)
(foreach ins lst
(setq ins (vlax-ename->vla-object ins))
(if (= (vla-get-objectname ins) "AcDbBlockReference")
(if (vlax-property-available-p ins 'path)
(princ "\nThis is external reference! Skip.")
(_pl:block-color blocks ins color lays)
) ;_ end of if
(princ "\nThis isn't block! Try pick other.")
) ;_ end of if
) ;_ end of repeat
(vla-regen adoc acallviewports)
(vla-endundomark adoc)
) ;_ end of progn
) ;_ end of if
(princ)
) ;_ end of defun

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
(vlax-for e (vla-item blocks (vla-get-name ins))
(setq lay (vla-item lays (vla-get-layer e)))
(if (= (vla-get-freeze lay) :vlax-true)
(progn (setq layfrz (cons lay layfrz))
(vla-put-freeze lay :vlax-false)
) ;_ end of progn
) ;_ end of if
(if (= (vla-get-lock lay) :vlax-true)
(progn (setq layloc (cons lay layloc))
(vla-put-lock lay :vlax-false)
) ;_ end of progn
) ;_ end of if
(vl-catch-all-apply (function vla-put-color) (list e color))
(if (and (= (vla-get-objectname e) "AcDbBlockReference")
(not (vlax-property-available-p e 'path))
) ;_ end of and
(_pl:block-color blocks e color lays)
) ;_ end of if
(foreach i layfrz (vla-put-freeze i :vlax-true))
(foreach i layloc (vla-put-lock i :vlax-true))
) ;_ end of vlax-for
) ;_ end of defun

(progn
(princ
"\BLCCA - Changes in the color of selected blocks in the area"
) ;_ end of princ
(princ)
) ;_ end of progn

|;
(defun bg:blfixdialog ( / dcl dch all_block_list fix_block_list what opt Express )
(defun sync1 ( )
(setq all_block_list(ACAD_STRLSORT
(vl-remove-if-not '(lambda(x) (or
(and
(bg:bitset opt 2048) ;;;Unnamed
(wcmatch x "`*U*")
)
(snvalid x)
)
)
((lambda (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
)
"block"
)

)
)
)
(updatelist "allblock" all_block_list)
(updatelist "fixblock" (setq fix_block_list nil))
(set_tile "allblock" "0")
)
(defun _move_ux ()
(if (= (get_tile "ux") "0")
(progn
(updatelist
"allblock"
(vl-remove-if-not 'snvalid all_block_list)
) ;_ end of updatelist
(updatelist
"fixblock"
(vl-remove-if-not 'snvalid fix_block_list)
) ;_ end of updatelist
) ;_ end of progn
(progn
(updatelist "allblock" all_block_list)
(updatelist "fixblock" fix_block_list)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(defun sync2 ( )
(setq fix_block_list(ACAD_STRLSORT
(vl-remove-if-not '(lambda(x) (or
(and
(bg:bitset opt 2048) ;;;Unnamed
(wcmatch x "`*U*")
)
(snvalid x)
)
)
((lambda (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
)
"block"
)
)
)
)
(updatelist "allblock" (setq all_block_list nil))
(updatelist "fixblock" fix_block_list)
(set_tile "fixblock" "0")
)

(defun move_to ( Fromlst Tolst indexlist / i tmp )
;;; (setq Fromlst all_block_list)
;;; (setq Tolst fix_block_list)
;;; (setq indexlist '(0 1 2 3 4))
(setq i -1 tmp nil)
(repeat (length Fromlst)
(if (vl-position (setq i (1+ i)) indexlist)
(if (not (vl-position (nth i Fromlst) Tolst))
(setq Tolst (cons (nth i Fromlst) Tolst))
)
(setq tmp (cons (nth i Fromlst) tmp))
)
)
(list (ACAD_STRLSORT(reverse tmp))(ACAD_STRLSORT(reverse Tolst)))
)
(defun synclist (key1 key2 / indexlist tmp lst1 lst2 k1 k2)
(setq k1 (get_tile key1)
k2 (get_tile key2)
indexlist (read (strcat "(" k1 ")"))
)
(if (= key1 "allblock")
(setq lst1 all_block_list lst2 fix_block_list)
(setq lst2 all_block_list lst1 fix_block_list)
)
(setq tmp (move_to lst1 lst2 indexlist))
(setq lst1 (car tmp) lst2 (cadr tmp))
(UpdateList key1 lst1)
(UpdateList key2 lst2)
;;; (if (<= (apply 'max (read (strcat "(" k1 ")")))(1-(length lst1)))
;;; (set_tile key1 k1)
;;; (set_tile key1 "0")
;;; )
;;; (if (\";fixed_width=true;alignment=centered;}"
":button {key = \"b2\";label = \">>\";fixed_width=true;alignment=centered;}"
":button {key = \"b4\";label = \"<<\"" "\"Select >\"") ";fixed_width = true;alignment = centered;height=3;}}")
":spacer{width=0;height=5;}}"
(strcat ":boxed_column{label=" (if IzRus "\"ֱכמךט הכ םמנלאכטחאצטט\"" "\"Fix block list\"") ";:list_box{width=31;height=26;multiple_select=true;key=\"fixblock\";}}}")
(strcat "spacer_1;:boxed_row{label=" (if IzRus "\"־ןצטט\"" "\"Options\"") ";" ":boxed_row{label=\"\";fixed_width=true;alignment=left;:column{")
(strcat ":row{label=\"\";fixed_width=true;alignment=left;:text{label=" (if IzRus "\" ׂטןכטםטט\"" "\" LineType\"") ";}}")
(strcat ":row{label=\"\";fixed_width=true;alignment=left;:text{label="(if IzRus "\" ײגוע\"" "\" Color\"") ";}}")
(strcat ":row{label=\"\";fixed_width=true;alignment=left;:text{label="(if IzRus "\" ֲוס\"" "\" LineWeight\"") ";}}")
;;;(if (zerop (getvar "PSTYLEMODE"))
(strcat ":row{label=\"\";fixed_width=true;alignment=left;:text{label="(if IzRus "\" ׁעטכ ןוקאעט\"" "\" Plot style\"") ";}}")
;;;""
;;; )
"}:column{:row{label=\"\";fixed_width=true;alignment=left;"
(strcat ":radio_button {key=\"o11\";label=" (if IzRus "\"ןמבכמךף\"" "\"byblock\"") ";value=\"1\";}")
(strcat ":radio_button {key=\"o12\";label=" (if IzRus "\"ןמסכמ‏\"" "\"bylayer\"") ";value=\"0\";}")
(strcat ":radio_button {key=\"o13\";label="(if IzRus "\"םו לוםע\"" "\"skip\"")";value=\"0\";}")
"}:row{fixed_width=true;alignment=left;"
(strcat ":radio_button {key=\"o21\";label=" (if IzRus "\"ןמבכמךף\"" "\"byblock\"") ";value=\"1\";}")
(strcat ":radio_button {key=\"o22\";label=" (if IzRus "\"ןמסכמ‏\"" "\"bylayer\"") ";value=\"0\";}")
(strcat ":radio_button {key=\"o23\";label="(if IzRus "\"םו לוםע\"" "\"skip\"")";value=\"0\";}}")
":row{label=\"\";fixed_width=true;alignment=left;"
(strcat ":radio_button {key=\"o31\";label=" (if IzRus "\"ןמבכמךף\"" "\"byblock\"") ";value=\"1\";}")
(strcat ":radio_button {key=\"o32\";label=" (if IzRus "\"ןמסכמ‏\"" "\"bylayer\"") ";value=\"0\";}")
(strcat ":radio_button {key=\"o33\";label="(if IzRus "\"םו לוםע\"" "\"skip\"")";value=\"0\";}")
"}"
;;;(if (zerop (getvar "PSTYLEMODE"))
;;; (strcat
":row{label=\"\";fixed_width=true;alignment=left;"
(strcat ":radio_button {key=\"o41\";label=" (if IzRus "\"ןמבכמךף\"" "\"byblock\"") ";value=\"1\";}")
(strcat ":radio_button {key=\"o42\";label=" (if IzRus "\"ןמסכמ‏\"" "\"bylayer\"") ";value=\"0\";}")
(strcat ":radio_button {key=\"o43\";label="(if IzRus "\"םו לוםע\"" "\"skip\"")";value=\"0\";}")
"}"
;;; );_strcat
;;; ""
;;; )
"}}spacer_1;:boxed_column{spacer_1;"
(strcat ":toggle {key = \"layer\"; label=" (if IzRus "\"ׁכמי םא \\\"0\\\"\"" "\"Layer to \\\"0\\\"\"") ";}")
"spacer_1;"
(strcat ":toggle{key=\"plw\";label=" (if IzRus "\"״טנטםא ןמכטכטםטי=0\"" "\"Pline width=0\"") ";}")
"spacer_1;"
(strcat ":toggle{key=\"ux\";label=" (if IzRus "\"ֲךכ‏קא םוטלוםמגאםםו (*U)\"" "\"Use unnamed (*U)\"") ";}")
"spacer_1;}}"
":column{"
(strcat ":toggle{key=\"lock\";label=\"" (if IzRus "ָדםמנטנמגאע חאבכמךטנמגאםםו סכמט" "Ignore locked layers") "\";}")
(strcat ":toggle{key=\"su\";label=\"" (if IzRus "׃סעאםמגטע מהטםאךמגו לאסרעאב" "Scale uniformly") "\";}")
(strcat ":toggle{key=\"ae\";label=\"" (if IzRus "׀אחנורטע נאסקכוםוםטו" "Allow exploding") "\";}")
"}"
"spacer_1;ok_cancel;}"
)
(write-line line ofile)
) ;_ end of foreach
(setq ofile (close ofile))
(findfile fname)
)
) ;_ end of cond
) ;_defun

(defun selectb ( / ss i lst bn)
(if (setq ss (ssget "_:L" '((0 . "INSERT"))))
(setq i (sslength ss))
(setq i 0)
)
(setq lst fix_block_list)
(repeat i ;_ end setq
(setq bn (bg:block-get-name (ssname ss (setq i(1- i)))))
(if (not (VL-POSITION bn lst))(setq lst (cons bn lst)))
) ;
(setq fix_block_list lst)
(mapcar '(lambda (x)(setq all_block_list (vl-remove x all_block_list))) fix_block_list)
)
(setq Express
(and (vl-position "acetutil.arx" (arx))
(not
(vl-catch-all-error-p
(vl-catch-all-apply
(function (lambda nil (acet-sys-shift-down)))
)
)
)
)
)
(if (not (vl-file-directory-p (setq what (_GetSavePath))))
(progn
(cond
(Express
(acet-ui-message "Save Path not Valid" "Warning" 16)
)
(t
(princ "\n** Save Path not Valid **")
)
)
(exit)
)
)
;;=== End func
(setq dcl (strcat what "\\BGBlFix_V" (bg:ver) ".dcl"))
(setq what nil opt 3657)
;;;(setq what nil opt 30281)

(_WriteDCL dcl)
(if
(not
(and
(setq dcl (findfile dcl)) ;; Check for DCL file
( what 2))
(cond
(
(not (new_dialog "FIXBLOCK" dch "" (cond ( *screenpoint* ) ( '(-1 -1) ))))

;; If our global variable *screenpoint* has a value it will be
;; used to position the dialog, else the default (-1 -1) will be
;; used to center the dialog on screen.

;; Should the dialog definition not exist, we unload the dialog
;; file from memory and inform the user:

(setq dch (unload_dialog dch))
(princ "\n** Dialog could not be Loaded **")
)
(t
(initopt)
(updatelist "allblock" all_block_list)
(updatelist "fixblock" fix_block_list)
(set_tile "fixblock" "0")
(set_tile "allblock" "0")
(set_tile "tile" (strcat "BGBLFIX v." (bg:ver)))
(action_tile "accept" "(setq opt (getopt) *screenpoint* (done_dialog 1))")
(action_tile "b1" "(synclist \"allblock\" \"fixblock\")")
(action_tile "b2" "(synclist \"fixblock\" \"allblock\")")
(action_tile "b3" "(sync2)")
(action_tile "b4" "(sync1)")
(action_tile "select" "(setq opt (getopt) *screenpoint* (done_dialog 4))")
(action_tile "ux" "(_move_ux)")
(if (zerop (getvar "PSTYLEMODE"))
(progn
(mode_tile "o41" 0)
(mode_tile "o42" 0)
(mode_tile "o43" 0)
)
(progn
(mode_tile "o41" 1)
(mode_tile "o42" 1)
(mode_tile "o43" 1)
)
)
(setq what (start_dialog))
(cond ((= what 4)
(selectb)
(updatelist "allblock" all_block_list)
(updatelist "fixblock" fix_block_list)
)
((= what 1)
;;; (princ "\nFixblock= ")
;;; (princ fix_block_list)
;;; (princ "\nOptions = ")
;;; (princ opt)(princ "\n")
);;;Accept
(t (setq what nil fix_block_list nil opt nil))
)
)
);_cond
) ;_while what
(if fix_block_list (cons opt fix_block_list))
)

;;; ;;;Line Type
;;; (if (bg:bitset opt 1)(set_tile "o11" "1")(set_tile "o11" "0"))
;;; (if (bg:bitset opt 2)(set_tile "o12" "1")(set_tile "o12" "0"))
;;; (if (bg:bitset opt 4)(set_tile "o13" "1")(set_tile "o13" "0"))
;;; ;;;COlor
;;; (if (bg:bitset opt 8) (set_tile "o21" "1")(set_tile "o21" "0"))
;;; (if (bg:bitset opt 16)(set_tile "o22" "1")(set_tile "o22" "0"))
;;; (if (bg:bitset opt 32)(set_tile "o23" "1")(set_tile "o23" "0"))
;;; ;;;Lineweight
;;; (if (bg:bitset opt 64) (set_tile "o31" "1")(set_tile "o31" "0"))
;;; (if (bg:bitset opt 128)(set_tile "o32" "1")(set_tile "o32" "0"))
;;; (if (bg:bitset opt 256)(set_tile "o33" "1")(set_tile "o33" "0"))
;;; ;;;Layer 0
;;; (if (bg:bitset opt 512)(set_tile "layer" "1")(set_tile "layer" "0"))
;;; ;;;Pline width
;;; (if (bg:bitset opt 1024)(set_tile "plw" "1")(set_tile "plw" "0"))
;;; ;;; Unnamed
;;; (if (bg:bitset opt 2048)(set_tile "ux" "1")(set_tile "ux" "0"))

(defun bg:blfix ( lst / cnt adoc opt ss cnta isRus locklay bobj)
;;; lst - list, return (setq lst (bg:blfixdialog)) lst=(option "DKL1" BLK2" BLK3" ... )
;;; locklay - t -unlock lay nil - not
(setq cnt 0 opt (car lst) lst (cdr lst) isRus (= (getvar "DWGCODEPAGE") "ANSI_1251"))
(setq locklay (bg:bitset opt 4096))
(and locklay (bg:layer-status-save))
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark adoc)
(bg:progress-init "FIX Block Definition " (length lst))
(foreach bname lst
(bg:progress (setq cnt (1+ cnt)))
(vlax-for sub_item (setq bobj (vla-item (vla-get-blocks adoc) bname))
(cond
((bg:bitset opt 1) ;;_Line type byblock
(if (vlax-write-enabled-p sub_item)
(vla-put-linetype sub_item "ByBlock")
)
)
((bg:bitset opt 2) ;;_Line type bylayer
(if (vlax-write-enabled-p sub_item)
(vla-put-linetype sub_item "byLayer")
)
)
(t nil)
)
(cond
((bg:bitset opt 8) ;;_Color type byblock
(if (vlax-write-enabled-p sub_item)
(vla-put-color sub_item acByBlock)
)
)
((bg:bitset opt 16) ;;_Color type bylayer
(if (vlax-write-enabled-p sub_item)
(vla-put-color sub_item acByLayer)
)
)
(t nil)
)
(cond
((bg:bitset opt 64) ;;_LineWeigth type byblock
(if (vlax-write-enabled-p sub_item)
(vla-put-LineWeight sub_item aclnwtbyblock)
)
)
((bg:bitset opt 128) ;;_LineWeigth type bylayer
(if (vlax-write-enabled-p sub_item)
(vla-put-LineWeight sub_item acLnWtByLayer)
)
)
(t nil)
)
(if (zerop (getvar "PSTYLEMODE"))
(cond ;_32768
((bg:bitset opt 32768) ;;_Plot style type byblock
(if (vlax-write-enabled-p sub_item)
(vla-put-PlotStyleName sub_item "ByBlock")
)
)
((bg:bitset opt 65536) ;;_Plot style type bylayer
(if (vlax-write-enabled-p sub_item)
(vla-put-PlotStyleName sub_item "byLayer")
)
)
(t nil)
)
)
(if (bg:bitset opt 512) ;;_Layer to 0
(if (vlax-write-enabled-p sub_item)
(vla-put-Layer sub_item "0")
)
)
(if (and (bg:bitset opt 1024)(vlax-property-available-p sub_item "ConstantWidth"));_ Pline width
(vl-catch-all-apply
'(lambda ()
(vla-put-ConstantWidth sub_item 0.)
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
)
(if (and (bg:bitset opt 8192)(eq (vla-get-ObjectName sub_item) "AcDbBlockReference"));_ Scale Uniformly
(vl-catch-all-apply
'(lambda ()
(vla-put-XScaleFactor sub_item 1)
(vla-put-YScaleFactor sub_item 1)
(vla-put-ZScaleFactor sub_item 1)
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
)
)
(if (bg:bitset opt 16384) ;;_Allow expolding
(vla-put-Explodable bobj :vlax-true)
;;;(vla-put-Explodable bobj :vlax-false)
)
)
(bg:progress-clear)
(if (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 66 1)))) ;;;Fix attribute
(progn
(setq cnta 0)
(bg:progress-init "FIX Attribute " (sslength ss))
(foreach blk (mapcar (function vlax-ename->vla-object) (vl-remove-if (function listp)
(mapcar (function cadr) (ssnamex ss))))
(bg:progress (setq cnta (1+ cnta)))
(if (vl-position (bg:block-get-name blk) lst)
(foreach at (append (vlax-invoke blk 'GETATTRIBUTES)
(vlax-invoke blk 'GETCONSTANTATTRIBUTES)
)
(cond
((bg:bitset opt 1) ;;_Line type byblock
(if (vlax-write-enabled-p at)
(vla-put-linetype at "ByBlock")
)
)
((bg:bitset opt 2) ;;_Line type bylayer
(if (vlax-write-enabled-p at)
(vla-put-linetype at "byLayer")
)
)
(t nil)
)
(cond
((bg:bitset opt 8) ;;_Color type byblock
(if (vlax-write-enabled-p at)
(vla-put-color at acByBlock)
)
)
((bg:bitset opt 16) ;;_Color type bylayer
(if (vlax-write-enabled-p at)
(vla-put-color at acByLayer)
)
)
(t nil)
)
(cond
((bg:bitset opt 64) ;;_LineWeigth type byblock
(if (vlax-write-enabled-p at)
(vla-put-LineWeight at aclnwtbyblock)
)
)
((bg:bitset opt 128) ;;_LineWeigth type bylayer
(if (vlax-write-enabled-p at)
(vla-put-LineWeight at acLnWtByLayer)
)
)
(t nil)
)
(if (bg:bitset opt 512) ;;_Layer to 0
(if (vlax-write-enabled-p at)
(vla-put-Layer at "0")
)
)
)
)
)
(bg:progress-clear)
)
)
(vla-endundomark adoc)
(and locklay (bg:layer-status-restore))
(vla-regen adoc acallviewports)
(princ (if isRus
(strcat "\nָחלוםוםמ " (itoa cnt) " בכמךמג")
(strcat "\nFixed " (itoa cnt) " blocks")
)
)
(princ)
)

(defun c:BGResetXRef
( / *error* _Settings _GetDocumentObject acapp acdoc acdocs acver dbxdoc dcl def han inc lst props sel tile tiles xrf xreflst )

;;-------------------=={ Reset XRef Layers }==--------------------------;;
;; http://www.theswamp.org/index.php?topic=40132.0 ;;
;; ;;
;;; ;;
;; This program enables the user to reset all or specific layer ;;
;; properties of xref dependent layers to match the properties ;;
;; present in the xref source drawing file. ;;
;; ;;
;; Upon starting the program, the user is prompted to select an xref ;;
;; whose layers are to be reset. Following a valid selection, the ;;
;; properties of all layers dependent on the selected xref are reset ;;
;; to match the values found in the source drawing for the selected ;;
;; xref. ;;
;; ;;
;; From the selection prompt, the user may also choose 'Multiple', ;;
;; 'All', or 'Settings'. ;;
;; ;;
;; If 'Multiple' is selected, the user may select several xrefs using ;;
;; the standard selection interface (e.g. via window selection). ;;
;; ;;
;; If 'All' is selected, the layer properties of every xref found in ;;
;; the active drawing is reset to match the original values found in ;;
;; the respective source drawings. ;;
;; ;;
;; Finally, if the 'Settings' option is selected, a dialog interface ;;
;; is displayed allowing the user to choose which layer properties ;;
;; are to be reset. ;;
;; ;;
;; The user may select multiple properties to be reset from: Colour, ;;
;; Linetype, Lineweight, Plot, Plot Style, Frozen in Viewports, On, ;;
;; Locked, Frozen, & Description. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2014 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2011-11-19 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;
;; Version 1.1 - 2011-11-27 ;;
;; ;;
;; - Added code to search for XRef Source File in working directory & ;;
;; support directories if not found at XRef Path. ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 2014-04-13 ;;
;; ;;
;; - Program entirely rewritten. ;;
;; - Modified program to account for layers whose colour property ;;
;; uses a True Colour or Colour Book colour. ;;
;;----------------------------------------------------------------------;;

(defun *error* ( msg )
(if (< 0 han) (setq han (unload_dialog han)))
(if (and dcl (setq dcl (findfile dcl))) (vl-file-delete dcl))
(if (and dbxdoc (not (vlax-object-released-p dbxdoc))) (vlax-release-object dbxdoc))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(defun _Settings ( code / bit dcl han tmp )
(cond
(
(not
(and
(setq dcl (vl-filename-mktemp nil nil ".dcl"))
(setq tmp (open dcl "w"))
(progn
(foreach line
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
'(
"rxl : dialog { label = \"ֽאסענמיךט\"; spacer;"
" : boxed_column { label = \"ׁגמיסעגא הכ גמססעאםמגכוםט\"; width = 65.0; fixed_width = true; alignment = centered; spacer;"
" : row { alignment = centered; spacer; "
" : column {"
" : toggle { key = \"colour\"; label = \"ײגוע\"; }"
" : toggle { key = \"linetype\"; label = \"ׂטן כטםטט\"; }"
" : toggle { key = \"lineweight\"; label = \"ֲוס כטםטט\"; }"
" }"
" : column {"
" : toggle { key = \"plot\"; label = \"ֿוקאע\"; }"
" : toggle { key = \"plotstyle\"; label = \"ׁעטכ ןוקאעט\"; }"
" : toggle { key = \"frozenvp\"; label = \"ַאלמנמזום םא םמגץ ֲ\"; }"
" }"
" : column {"
" : toggle { key = \"on\"; label = \"ֲךכ\"; }"
" : toggle { key = \"locked\"; label = \"ֱכמךטנמגאע\"; }"
" : toggle { key = \"frozen\"; label = \"ַאלמנמחטע\"; }"
" }"
" : column {"
" : toggle { key = \"description\"; label = \"־ןטסאםטו\"; }"
" spacer;"
" : toggle { key = \"selectall\"; label = \"ֲבנאע גסו\"; }"
" }"
" }"
" spacer;"
" }"
" spacer; ok_cancel;"
"}"
)
'(
"rxl : dialog { label = \"Settings\"; spacer;"
" : boxed_column { label = \"Properties to Reset\"; width = 65.0; fixed_width = true; alignment = centered; spacer;"
" : row { alignment = centered; spacer; "
" : column {"
" : toggle { key = \"colour\"; label = \"Colour\"; }"
" : toggle { key = \"linetype\"; label = \"Linetype\"; }"
" : toggle { key = \"lineweight\"; label = \"Lineweight\"; }"
" }"
" : column {"
" : toggle { key = \"plot\"; label = \"Plot\"; }"
" : toggle { key = \"plotstyle\"; label = \"Plot Style\"; }"
" : toggle { key = \"frozenvp\"; label = \"Frozen in VP\"; }"
" }"
" : column {"
" : toggle { key = \"on\"; label = \"On\"; }"
" : toggle { key = \"locked\"; label = \"Locked\"; }"
" : toggle { key = \"frozen\"; label = \"Frozen\"; }"
" }"
" : column {"
" : toggle { key = \"description\"; label = \"Description\"; }"
" spacer;"
" : toggle { key = \"selectall\"; label = \"Select All\"; }"
" }"
" }"
" spacer;"
" }"
" spacer; ok_cancel;"
"}"
)
)
(write-line line tmp)
)
(setq tmp (close tmp))
(while (null (findfile dcl)))
(< 0 (setq han (load_dialog dcl)))
)
(new_dialog "rxl" han)
)
)
(princ "\nError Loading Dialog.")
)
( t
(setq bit 1
tmp code
)
(if (= 1023 tmp)
(set_tile "selectall" "1")
)
(foreach tile
(setq tiles
'(
"colour"
"linetype"
"lineweight"
"plot"
"plotstyle"
"frozenvp"
"on"
"locked"
"frozen"
"description"
)
)
(if (= bit (logand tmp bit))
(set_tile tile "1")
(set_tile tile "0")
)
(action_tile tile
(strcat
"(setq tmp (boole 6 tmp " (itoa bit) "))"
"(set_tile \"selectall\" (if (= 1023 tmp) \"1\" \"0\")))"
)
)
(setq bit (lsh bit 1))
)
(action_tile "selectall"
(strcat
"(foreach tile tiles (set_tile tile $value))"
"(if (eq \"1\" $value)"
" (setq tmp 1023)"
" (setq tmp 0)"
")"
)
)
(if (= 1 (start_dialog)) (setq code tmp))
)
)
(if (< 0 han) (setq han (unload_dialog han)))
(if (and dcl (setq dcl (findfile dcl))) (vl-file-delete dcl))
code
)

(defun _GetDocumentObject ( dbxdoc acdocs xref / path xpath )
(setq xpath (cdr (assoc 1 (entget (tblobjname "BLOCK" xref)))))
(cond
( (null
(or
(setq path (findfile xpath))
(setq path (findfile (strcat (vl-filename-base xpath) ".dwg")))
)
)
(princ (strcat "\nSource Drawing for " xref " not Found."))
nil
)
( (cdr (assoc path acdocs))
)
( (null
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-open (list dbxdoc path))
)
)
dbxdoc
)
( (princ (strcat "\nUnable to Open " xref " Source Drawing."))
nil
)
)
)

(if (null (setq props (getenv "LMac\\RXLProps")))
(setq props (+ 1 2 4 8 512))
(setq props (atoi props))
)

(while (setq def (tblnext "BLOCK" (null def)))
(if (= 4 (logand 4 (cdr (assoc 70 def))))
(setq lst (cons "," (cons (cdr (assoc 2 def)) lst)))
)
)

(cond
( (null lst)
(princ "\nNo XRefs found in Drawing.")
)
( t
(setq acapp (vlax-get-acad-object)
acdoc (vla-get-activedocument acapp)
dbxdoc (vla-GetInterfaceObject acapp
(if (< (setq acver (atoi (getvar "ACADVER"))) 16)
"ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acver))
)
)
acdocs (vlax-for doc (vla-get-documents acapp)
(setq acdocs (cons (cons (vla-get-fullname doc) doc) acdocs))
)
)
(while
(progn
(setvar 'ERRNO 0)
(initget "ֽוסךמכךמ ֲסו ָל ֽאסענמיךט Multiple All Name Settings _Multiple All Name Settings Multiple All Name Settings")
(setq sel (entsel
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"\nֲבונטעו XRef הכ סבנמסא םאסענמוך טכט [ֽוסךמכךמ/ֲסו/גבמנ ןמ ָלוםט/ֽאסענמיךט] : "
"\nSelect XRef to Reset or [Multiple/All/select by Name/Settings] : "
)
))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, try again.")
)
( (null sel)
nil
)
( (eq "Multiple" sel)
(setvar 'NOMUTT 1)
(princ(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"\nֲבונטעו XRefs הכ סבנמסא םאסענמוך : "
"\nSelect XRefs to Reset : "
)
)
(setq sel
(vl-catch-all-apply 'ssget
(list
(list '(0 . "INSERT") (cons 2 (apply 'strcat (cdr lst))))
)
)
)
(setvar 'NOMUTT 0)
(if (and sel (not (vl-catch-all-error-p sel)))
(repeat (setq inc (sslength sel))
(LM:ResetXRefLayers
(setq xrf (cdr (assoc 2 (entget (ssname sel (setq inc (1- inc)))))))
(_GetDocumentObject dbxdoc acdocs xrf)
acdoc
props
)
)
)
nil
)
( (eq "All" sel)
(while (setq def (tblnext "BLOCK" (null def)))
(if (= 4 (logand 4 (cdr (assoc 70 def))))
(LM:ResetXRefLayers
(setq xrf (cdr (assoc 2 def)))
(_GetDocumentObject dbxdoc acdocs xrf)
acdoc
props
)
)
)
nil
)
( (eq "Name" sel)
(while (setq def (tblnext "BLOCK" (null def)))
(if (= 4 (logand 4 (cdr (assoc 70 def))))
(setq xreflst (cons (cdr (assoc 2 def)) xreflst))
)
)
(foreach xrf (_dwgru-get-user-dcl
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"ֲבונטעו ססכךט "
"Select XRefs"
)
(acad_strlsort xreflst) t)
(LM:ResetXRefLayers
xrf
(_GetDocumentObject dbxdoc acdocs xrf)
acdoc
props
)
)
nil
)

( (eq "Settings" sel)
(setq props (_Settings props))
)
( (vl-consp sel)
(if (eq "INSERT" (cdr (assoc 0 (setq sel (entget (car sel))))))
(if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 sel)))))))
(LM:ResetXRefLayers
(setq xrf (cdr (assoc 2 sel)))
(_GetDocumentObject dbxdoc acdocs xrf)
acdoc
props
)
(princ "\nSelected Block is not an XRef.")
)
(princ "\nInvalid Object Selected.")
)
)
)
)
)
(vla-regen acdoc acallviewports)
(vlax-release-object dbxdoc)
)
)
(setenv "LMac\\RXLProps" (itoa props))
(princ)
)
(defun LM:ResetXRefLayers ( xref xrdoc acdoc props / _GetLayerProperties ass bit data name pos value xdef )
;;; Lee Mac 2011 http://www.lee-mac.com
(defun _GetLayerProperties ( doc props / bit lst data )
(vlax-for layer (vla-get-layers doc)
(setq bit 1
lst nil
)
(foreach prop
'(
color
linetype
lineweight
plottable
plotstylename
viewportdefault
layeron
lock
freeze
description
)
(if
(and
(vlax-property-available-p layer prop)
(= bit (logand bit props))
)
(setq lst (cons (cons bit (vlax-get-property layer prop)) lst))
)
(setq bit (lsh bit 1))
)
(setq data
(cons
(cons
(strcase (vla-get-name layer))
(reverse lst)
)
data
)
)
)
data
)

(cond
( (null xrdoc)
nil
)
( (vl-catch-all-error-p
(setq xdef
(vl-catch-all-apply 'vla-item (list (vla-get-blocks acdoc) xref))
)
)
(princ "\nXRef not present in Drawing.")
nil
)
( (setq data (_GetLayerProperties xrdoc props))
(vla-reload xdef)

(vla-startundomark acdoc)
(vlax-for layer (vla-get-layers acdoc)
(setq bit 1)
(if
(and
(setq pos (vl-string-position 124 (setq name (strcase (vla-get-name layer)))))
(eq (strcase xref) (substr name 1 pos))
(setq ass (cdr (assoc (substr name (+ 2 pos)) data)))
)
(foreach prop
'(
color
linetype
lineweight
plottable
plotstylename
viewportdefault
layeron
lock
freeze
description
)
(if
(and
(vlax-property-available-p layer prop t)
(= bit (logand bit props))
(setq value (cdr (assoc bit ass)))
)
(if (and (= 2 bit) (not (eq "CONTINUOUS" (strcase value))))
(vl-catch-all-apply 'vlax-put-property (list layer prop (strcat xref "|" value)))
(vl-catch-all-apply 'vlax-put-property (list layer prop value))
)
)
(setq bit (lsh bit 1))
)
)
)
(vla-endundomark acdoc)
t
)
)
)

(defun c:BGAll2RGB ( / accm c e i s _UpdateTrueColor _UpdateTrueColorNested )
;;; All to RGB - Lee Mac - http://www.lee-mac.com
;;; Converts the ACI colours of all entities to the RGB TrueColor equivalent
;;;http://www.cadtutor.net/forum/showthread.php?65645-Convert-from-index-colours-to-true-colours&s=b86c725f0e1c2793ae84f0c7babc7f59
(defun _UpdateTrueColor ( e c)
(if (eq c 7) ;_Black/Wםite
(vla-SetRGB accm 0 0 0)
(vla-put-colorindex accm c)
)
(entmod
(append e
(list
(cons 420
(LM:RGB->True
(vla-get-red accm)
(vla-get-green accm)
(vla-get-blue accm)
)
)
)
)
)
)
(defun _UpdateTrueColorNested ( e / c)
;;; (setq e (car(entsel)))
(if (and
(eq "INSERT" (cdr (assoc 0 e)))
(setq e (tblobjname "BLOCK" (cdr (assoc 2 e))))
)
(while (setq e (entnext e))
(if (and (setq c (cdr (assoc 62 (entget e))))
(not (zerop c))
)
(_UpdateTrueColor (entget e) c)
)
(if (eq "INSERT" (cdr (assoc 0 (entget e))))
(_UpdateTrueColorNested (entget e))
)
)
)
)
(if
(and
(setq s (ssget "_:L"))
(setq accm
(vla-getinterfaceobject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
)
(progn
(repeat (setq i (sslength s))
(setq e (entget (ssname s (setq i (1- i)))))
(if (and (setq c (cdr (assoc 62 e)))
(not (assoc 420 e))
)
(_UpdateTrueColor e c)
)
(_UpdateTrueColorNested e)
)
(vlax-release-object accm)
)
)
(vl-cmdf "_regenall")
(princ)
)
;;;================================================================================
;;;Written By Michael Puckett.
;;;ׁןטסמך ‎כולוםעמג סטלגמכםץ עאבכטצ ְגעמְִֺא
;;; - s- טל עאבכטצ
;;;ֿנטלונ - סןטסמך גסוץ סכמוג - (setq all_layers (tablelist "LAYER"))
;;;(setq all_layers (tablelist "LAYER"))
;;;
;;;AutoLisp should return something like this :
;;;Start Coding Here
(defun tablelist (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
);_ while
);_ defun
;;;End Coding Here

(defun LM:RGB->True ( r g b )
;; RGB -> True - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values

(+
(lsh (fix r) 16)
(lsh (fix g) 8)
(fix b)
)
)
(defun bg:truecolor->RGB ( truecolor )
;;;USE (BG:truecolor->RGB 8227990 )
(list
(logand (lsh truecolor -16) 255) ;; R
(logand (lsh truecolor -8) 255) ;; G
(logand truecolor 255) ;; B
)
)
;;------------------=={ Copy/Rename Block }==-----------------;;
;; ;;
;; Copies or Renames an single selected block reference with ;;
;; a name specified by the user. The program utilises an ;;
;; ObjectDBX Document interface to copy the block definition ;;
;; of the selected reference, perform the rename operation, ;;
;; then copy the renamed definion back to the working ;;
;; drawing. ;;
;; ;;
;; Program works with Dynamic Blocks & XRefs. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Version 1.3 - 25-08-2011 ;;
;;------------------------------------------------------------;;
;; url: http://lee-mac.com/copyblock.html ;;
;;------------------------------------------------------------;;
(defun c:BGCB nil (RenameBlock t))

(defun c:BGRB nil (RenameBlock nil))

;;------------------------------------------------------------;;

(defun RenameBlock ( copy / *error* _Name _ReleaseObject acapp acdoc b1 b2 d1 dbdoc df n1 n2 )

;;------------------------------------------------------------;;

(defun *error* ( msg )
(_ReleaseObject dbdoc)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)

(defun _Name ( obj )
(if (vlax-property-available-p obj 'EffectiveName)
(vla-get-EffectiveName obj)
(vla-get-Name obj)
)
)

(defun _ReleaseObject ( obj )
(and obj (eq 'VLA-OBJECT (type obj)) (not (vlax-object-released-p obj))
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vlax-release-object (list obj))
)
)
)
)

;;------------------------------------------------------------;;

(setq acapp (vlax-get-acad-object)
acdoc (vla-get-activedocument acapp)
acblk (vla-get-blocks acdoc)
)

(if
(and
(zerop(getvar "BLOCKEDITOR"))
(setq b1
(car
(LM:Selectif
(strcat
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"\nֲבונטעו ססכךף בכמךא הכ "
"\nSelect Block Reference to "
)
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(if copy "ֺמןטט" "ֿונוטלוםמגאםט")
(if copy "Copy" "Rename")
)
": ")
(lambda ( x ) (eq "INSERT" (cdr (assoc 0 (entget (car x))))))
entsel nil
)
)
)
(LM:CopyBlockDef acdoc (setq dbdoc (LM:ObjectDBXDocument acapp)) (setq n1 (_Name (setq b1 (vlax-ename->vla-object b1))))
(progn
(while
(progn
(setq n2
(getstring t
(strcat (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\nֲגוהטעו םמגמו טל בכמךא <" "\nSpecify New Block Name : "
)
)
)
(cond
( (eq "" n2) (setq n2 df)
nil
)
( (or (not (snvalid n2)) (tblsearch "BLOCK" n2))
(princ (if (= (getvar "DWGCODEPAGE") "ANSI_1251") "\nֽוגונםמו טכט ׁףשוסעגף‏שוו טל בכמךא." "\nBlock Name Invalid or Already Exists."))
)
)
)
)
n2
)
)
)
(progn
(if (and (vlax-property-available-p b1 'isDynamicBlock) (eq :vlax-true (vla-get-isDynamicBlock b1)))
(progn
(setq p1 (mapcar 'vla-get-value (vlax-invoke b1 'GetDynamicBlockProperties)))
(vla-put-name (if copy (setq b1 (vla-copy b1)) b1) n2)
(mapcar
(function
(lambda ( a b )
(or (eq "ORIGIN" (strcase (vla-get-PropertyName a))) (vla-put-value a b))
)
)
(vlax-invoke b1 'GetDynamicBlockProperties) p1
)
)
(vla-put-name (if copy (setq b1 (vla-copy b1)) b1) n2)
)
(if (eq :vlax-true (vla-get-isxref (setq d1 (vla-item acblk n2))))
(vla-reload d1)
)
(if copy (sssetfirst nil (ssadd (vlax-vla-object->ename b1))))
)
(if (not(zerop(getvar "BLOCKEDITOR")))
(bg:msg-Popup
(if (= (getvar "DWGCODEPAGE") "ANSI_1251") "ֲםטלאםטו" "Attention")
(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
"ֺמלאםהא םו נאבמעאוע ג נוהאךעמנו בכמךמג!"
"Command is not working in the Block Editor!"
)
16
)
)
)
(_ReleaseObject dbdoc)
(princ)
)

;;---------------=={ Copy Block Definition }==----------------;;
;; ;;
;; Copies the specified block defintion with new name as ;;
;; specified ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; acdoc - Document Object containing Block to copy ;;
;; dbdoc - ObjectDBX Document ;;
;; name1 - Name of block definition to copy ;;
;; name2 - Name to be used for copied definition ;;
;;------------------------------------------------------------;;
;; Returns: Copied VLA Block Definition Object, else nil ;;
;;------------------------------------------------------------;;
;;http://www.lee-mac.com/copyblockdefinition.html
(defun LM:CopyBlockDef ( acdoc dbdoc name1 name2 / acblk dbblk b1 b2 )
(setq acblk (vla-get-blocks acdoc)
dbblk (vla-get-blocks dbdoc)
)
(if
(and
(setq b1 (LM:GetItem acblk name1))
(not (LM:GetItem acblk name2))
(not(wcmatch name2 "`**")) ;;;Add VVA 2012-03-03
)
(progn
(vla-CopyObjects acdoc (LM:SafearrayVariant vlax-vbObject (list b1)) dbblk)
(vla-put-Name (setq b2 (LM:GetItem dbblk name1)) name2)
(vla-CopyObjects dbdoc (LM:SafearrayVariant vlax-vbObject (list b2)) acblk)
)
)
(LM:GetItem acblk name2)
)

;;--------------=={ VLA-Collection: Get Item }==--------------;;
;; ;;
;; Retrieves the item with index 'item' if present in the ;;
;; specified collection, else nil ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; collection - the VLA Collection Object ;;
;; item - the index of the item to be retrieved ;;
;;------------------------------------------------------------;;
;; Returns: the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;

(defun LM:GetItem ( collection item )
(if
(not
(vl-catch-all-error-p
(setq item (vl-catch-all-apply 'vla-item (list collection item)))
)
)
item
)
)

;;-----------------=={ ObjectDBX Document }==-----------------;;
;; ;;
;; Retrieves a version specific ObjectDBX Document object ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; acapp - AutoCAD VLA Application Object ;;
;;------------------------------------------------------------;;
;; Returns: VLA ObjectDBX Document object, else nil ;;
;;------------------------------------------------------------;;

(defun LM:ObjectDBXDocument ( acapp / acVer )
(vla-GetInterfaceObject acapp
(if ( 7
("lw" . 50) ; גוס כטםטט סכמ. nil -> 25
* ־םמ גנאזאועס ג סמעץ המכץ לטככטלוענא ט למזוע בע כ‏בל
* טח סכוהף‏שודמ נהא: 0, 5, 9, 13, 15, 18, 20, 25, 30, 35, 40, 50, 53, 60, 70,
* 80, 90, 100, 106, 120, 140, 158, 200 ט 211.
("lt" . "hidden") ; עטן כטםטט סכמ. nil -> Continuous
; ֵסכט מןטסאםט עטןא כטםטט ג acadiso.lin
; םוע, מבחאעוכםמ ףךאחגאע סכוהף‏שטי
; ןאנאלוענ
("ltfile" . "c:\\cad\\ltypes\\lt.lin") ; ןמכםי ןףע ך פאיכף ס מןטסאםטול
; עטןא כטםטט. ֵסכט פאיכ םאץמהטעס ג ןףעץ
; ןמההונזךט, ןףע למזםמ םו ףךאחגאע
("plot" . "y") ; ֿוקאעאע ("y") טכט םוע ("n") סכמי.
; nil -> "y"
("lock" . t) ; ֱכמךטנמגאע t טכט םוע nil סכמי.
("suff" . "_׀אחלונ") ;_ִמבאגכולי סףפפטךס ס עוךףשולף סכמ‏. ֵסכט חאהאם, ןמכו "name" טדםמנטנףועס
)
* ֲמחגנאשאוע vla-ףךאחאעוכ םא סמחהאםםי סכמי. ֵסכט סכמי סףשוסעגףוע, ודמ
* םאסענמיךט ןנטגמהעס ג סממעגועסעגטו ס ןונוהאםםל סןטסךמל.
* ׁכמי נאחלמנאזטגאועס, נאחבכמךטנףועס ט גךכ‏קאועס. ֽו אךעטגטנףועס.
* ֿנטלונ:
(bg:layer-create '(("name" . "Test")("color" . 1)("lw" . 50)))
* סמחהאע וסכט םוע ט סכמי Test צגועמל 1 (ךנאסםי) גוסמל כטםטט 0.5
;;;(bg:layer-create layer-list)
=========================================================================|;

(defun bg:layer-create (layer-list / vla_layer buf IsChange)
(setq layer-list
(mapcar
'(lambda (x) (cons (strcase (car x) t) (cdr x)))
layer-list
) ;_ end of mapcar
) ;_ end of setq
;;;ֵסכט וסע suff המבאגכול ג םאקאכמ סןטסךא, קעמב assoc םארוכ נאםרו
(if (cdr (assoc "suff" layer-list))
(progn
(setq layer-list
(vl-remove (assoc "name" layer-list) layer-list)
) ;_ end of setq
(setq layer-list
(append
(list
(cons "name"
(strcat (getvar "clayer")
(cdr (assoc "suff" layer-list))
) ;_ end of strcat
) ;_ end of cons
) ;_ end of list
layer-list
) ;_ end of append
) ;_ end of setq
) ;_ end of progn
) ;_ end of if
(setq buf (if (snvalid (cdr (assoc "name" layer-list)))
(cdr (assoc "name" layer-list))
(getvar "CLAYER")
) ;_ end of if
)
(if (setq vla_layer (TBLOBJNAME "layer" buf))
(setq IsChange nil
vla_layer (vlax-ename->vla-object vla_layer)
)
(setq IsChange t
vla_layer
(vla-add
(vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-layers
buf
) ;_ end of vla-add
) ;_ end of setq
)
(if (and IsChange (setq buf (cdr (assoc "color" layer-list))))
(vla-put-color
vla_layer
(if buf
buf
7
) ;_ end of if
) ;_ end of vla-put-color
) ;_ end of if
(if (and IsChange
(progn
(setq buf (cdr (assoc "lw" layer-list)))
(if (eq (type buf) 'STR)
(setq buf (atoi buf))
)
buf
)
)
(vla-put-lineweight vla_layer
(if buf
(if (member buf
(list aclnwt000 aclnwt030 aclnwt090
aclnwt005 aclnwt035 aclnwt100
aclnwt009 aclnwt040 aclnwt106
aclnwt013 aclnwt050 aclnwt120
aclnwt015 aclnwt053 aclnwt140
aclnwt018 aclnwt060 aclnwt158
aclnwt020 aclnwt070 aclnwt200
aclnwt025 aclnwt080 aclnwt211
) ;_ end of list
) ;_ end of member
buf
aclnwtbylwdefault
) ;_ end of if
aclnwtbylwdefault
) ;_ end of if
) ;_ end of vla-put-lineweight
) ;_ end of if
(if (and IsChange
(setq buf (cdr (assoc "lt" layer-list)))
(setq buf
(bg:linetype-load
buf
(cdr (assoc "ltfile" layer-list))
) ;_ end of _kpblc-linetype-load
) ;_ end of setq
) ;_ end of and
(vla-put-linetype vla_layer (vla-get-name buf))
(vla-put-linetype vla_layer "Continuous")
) ;_ end of if
(if (and IsChange (setq buf (cdr (assoc "plot" layer-list))))
(vla-put-plottable
vla_layer
(if (member (cdr (assoc "plot" layer-list))
'("n" "no" "N" "NO")
)
:vlax-false
:vlax-true
) ;_ end of if
) ;_ end of vla-put-Plottable
) ;_ end of if
(setq buf (cdr (assoc "lock" layer-list)))
(vla-put-lock
vla_layer
(if buf
:vlax-true
:vlax-false
) ;_ end of if
) ;_ end of vla-put-lock
(vla-put-layeron vla_layer :vlax-true)
(if (and
(not
(equal (vla-get-activelayer
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-activelayer
vla_layer
) ;_ end of equal
) ;_ end of not
(equal (vla-get-freeze vla_layer) :vlax-true)
) ;_ end of and
(vla-put-freeze vla_layer :vlax-false)
) ;_ end of if
vla_layer
) ;_ end of defun

;|=============================================================================
* װףםךצט ןמהדנףחךט עטןא כטםטט ג עוךףשטי פאיכ. ׃קטעגאוע גמחלמזםף‏
* כמךאכטחאצט‏ סטסעול.
* ֿאנאלוענ גחמגא:
* ltype-name טל עטןא כטםטט הכ אםדכטיסךמי גונסטט
* ltype-file טל פאיכא מןטסאםט עטןא כטםטט. nil -> "acadiso.lin"‏
* ֵסכט פאיכ ס מןטסאםטול עטןא כטםטט םו כוזטע ןמ ןףעל
* ןמההונזךט ךאהא, םאהמ ףךאחגאע ןמכםי ןףע ך םולף.
* ֿנטלונ גחמגא:
(bg:linetype-load "center" nil) ; הכ נףססךמי גונסטט ןמהדנףזאוע ־סוגא ט גמחגנאשאוע
; t ןנט ףסןוץו
*** ׁממעגועסעגטו םאטלוםמגאםטי כטםטי מבוסןוקטגאועס מדנמלםל סןטסךמל ltype_list
*** ךמעמני למזםמ ט םףזםמ המןמכםע :) ׂמכךמ םאהמ כטבמ גסו הוכאע לוכךטלט
*** בףךגאלט, כטבמ זוסעךמ סמבכ‏האע נודטסענ ג למלוםע גחמגמג.
*** ׂטן כטםטט "Continuous" מבנאבמעךו םו ןמהגונדאועס — מם וסע גמ גסוץ גונסטץ

=============================================================================|;

(defun bg:linetype-load (ltype-name ltype-file / ltype_list *activedoc*)
(setq *activedoc* (vla-get-activedocument (vlax-get-acad-object)))
(if (not (member (strcase ltype-name t)
'("continuous" "byblock" "bylayer")
) ;_ end of member
) ;_ end of not
(progn
(setq ltype_list '(("border" . "נאםע")
("border2" . "נאםע2")
("borderX2" . "נאםעX2")
("center" . "מסוגא")
("center2" . "מסוגא2")
("centerX2" . "מסוגאX2")
("dashdot" . "רענטץןףםךעטנםא")
("dashdot2" . "רענטץןףםךעטנםא2")
("dashdotX2" . "רענטץןףםךעטנםאX2")
("dashed" . "רענטץמגא")
("dashed2" . "רענטץמגא2")
("dashedX2" . "רענטץמגאX2")
("divide" . "כטםט_סדטבא")
("divide2" . "כטםט_סדטבא2")
("divideX2" . "כטםט_סדטבאX2")
("dot" . "ןףםךעטנםא")
("dot2" . "ןףםךעטנםא2")
("dotX2" . "ןףםךעטנםאX2")
("hidden" . "םוגטהטלא")
("hidden2" . "םוגטהטלא2")
("hiddenX2" . "םוגטהטלאX2")
("phantom" . "פאםעמל")
("phantom2" . "פאםעמל2")
("phantomX2" . "פאםעמלX2")
("fenceline1" . "מדנאזהוםטו1")
("fenceline2" . "מדנאזהוםטו2")
("tracks" . "ןףעט")
("batting" . "טחמכצט")
("hot_water_supply" . "דמנקא_גמהא")
("gas_line" . "דאחמןנמגמה")
("zigzag" . "חטדחאד")
("byblock" . "byblock")
("bylayer" . "bylayer")

)
ltype-name (strcase ltype-name t)
) ;_ end of setq
(if (not ltype-file)
(setq ltype-file "acadiso.lin")
;;; (setq ltype-file
;;; (strcat (_kpblc-dir-get-root-menu)
;;; (vl-filename-base ltype-file)
;;; ".lin"
;;; ) ;_ end of strcat
;;; ) ;_ end of setq
) ;_ end of if
(if (assoc ltype-name ltype_list)
(setq ltype-name
(if (vl-string-search "419" (vlax-product-key))
(cdr (assoc ltype-name ltype_list))
(car (assoc ltype-name ltype_list))
) ;_ end of if
) ;_ end of setq
) ;_ end of if
(if (not (tblsearch "ltype" ltype-name))
;; עטן כטםטט םו םאיהום, םאהמ ודמ חאדנףחטע. ׂטן כטםטט המכזום בע
;; מןטסאם ג פאיכו
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-load
(list
(vlax-get-property
*activedoc*
'linetypes
) ;_ end of vlax-get-property
ltype-name
ltype-file
) ;_ end of list
) ;_ end of vl-catch-all-apply
) ;_ end of vl-catch-all-error-p
) ;_ end of if
) ;_ end of progn
) ;_ end of if
(if (tblsearch "ltype" ltype-name)
(vla-item (vla-get-linetypes *activedoc*) ltype-name)
(vla-item (vla-get-linetypes *activedoc*)
"continuous"
) ;_ end of vla-item
) ;_ end of if
) ;_ end of defun

(defun C:BGCOLBL nil (mip_bgsetbylayer))
;;; BG Color By Layer

(defun mip_bgsetbylayer (/ *error* tmp cnt color Lay Lw pbar doc)
;;; ׃סעאםמגךא ןמסכמ‏ צגועא ןנטלטעטגמג ןמהמסםמג. ײגוע םו המכזום לוםעס
;;; ֵסכט צגוע חאהאם גםמ - סמחהאועס סכמי
;;; ּׁ C2L (Color 2 layer) http://forum.dwg.ru/showthread.php?p=1067614#post1067614
;;; (mip_bgsetbylayer)
(defun *error* (msg)
(princ msg)
(bg:progress-clear)
(bg:layer-status-restore)
(princ)
) ;_ end of defun
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(bg:layer-status-save)
;;;ֲוסעט סןטסמך סכמוג ס טץ סגמיסעגאלט, סכמט נאחבכמךטנמגאע, גךכ‏קוםםםו ט חאלמנמזוםםו םו ענמדאע. ַאלמנמזוםםו טסךכ‏קטע טח סןטסךא
(vlax-for Lay (vla-get-layers doc)
(vla-put-color Lay (vla-get-color Lay))
(if (< (vla-get-lineweight Lay) aclnwt025)
(vla-put-lineweight
Lay
(max aclnwt025 (getvar "LWDEFAULT"))
) ;_ end of vla-put-LineWeight
) ;_ end of if
) ;_ end of vlax-for
(setq cnt 0 pbar 0)
(bg:progress-clear)
(bg:progress-init (strcat "־בנאבאעגא‏ למהוכ ...") (/ (vla-get-count (vla-get-modelspace doc)) 500))
(vlax-for item (vla-get-modelspace doc)
(if (zerop (rem (setq cnt (1+ cnt)) 500))
(bg:progress (setq pbar (1+ pbar)))
)
(if (and (vlax-write-enabled-p item)
(vlax-property-available-p item 'Color)
) ;_ end of and
;;;ֽא גסךטי סכףקאי ןונוגמהטל טח RGB ג ACI
(vl-catch-all-apply
'vla-put-color
(list item (vla-get-color item))
) ;_ end of vl-catch-all-apply
) ;_ end of if
(setq color (vla-get-color item)
Lay (vla-get-layer item) ;_ "*|*"
Lw (vla-get-lineweight item)
) ;_ end of setq
(if (not (wcmatch Lay "*|*")) ;_ןנמןףסךאול גםורםטו ססכךט
(progn
(cond ((eq Lw aclnwtbyblock)
(setq Lw (max aclnwt025 (getvar "LWDEFAULT")))
)
((eq Lw aclnwtbylwdefault)
(setq Lw (max aclnwt025 (getvar "LWDEFAULT")))
)
((eq Lw aclnwtbylayer)
(setq
Lw (vla-get-lineweight
(vla-item (vla-get-layers doc) Lay)
) ;_ end of vla-get-LineWeight
) ;_ end of setq
)
(t nil)
) ;_ end of cond

(cond
((eq color acbylayer) nil)
((eq color (vla-get-color (vla-item (vla-get-layers doc) Lay))) ;_ײגוע חאהאם גםמ, םמ סמגןאהאוע ס צגועמל סכמ
;_ַאהאול צגוע ןמסכמ‏
(vl-catch-all-apply 'vla-put-color (list item acbylayer))
)
((and
(eq color acbyblock)
(eq acWhite (vla-get-color (vla-item (vla-get-layers doc) Lay))) ;_ײגוע חאהאם ןמבכמךף, צגוע סכמ acWhite
)
;_ַאהאול צגוע ןמסכמ‏
(vl-catch-all-apply 'vla-put-color (list item acbylayer))
)
(t
(if (eq color acbyblock)(setq color acWhite)) ;_ end of if
(setq tmp (vla-item (vla-get-layers doc) Lay))
(setq tmp
(_dwgru-layer-create
(list
(cons "name" (strcat Lay "_C_" (itoa color)))
(cons "color" color)
(cons "lw" Lw)
(cons "lt" (vla-get-linetype tmp))
(cons "plot"
(if (eq (vla-get-plottable tmp) :vlax-true)
"y"
"n"
) ;_ end of if
) ;_ end of cons
) ;_ end of list
) ;_ end of _dwgru-layer-create
) ;_ end of setq
(vl-catch-all-apply 'vla-put-color (list item acbylayer))
(vl-catch-all-apply
'vla-put-layer
(list item (vla-get-name tmp))
) ;_ end of VL-CATCH-ALL-APPLY
;;; Lw םו ענמדאול
)
) ;_ end of cond
(setq tmp (vla-item (vla-get-layers doc) Lay))
(if (and (vlax-write-enabled-p item)
(eq (vla-get-objectname item) "AcDbBlockReference")
(eq (vla-get-hasattributes item) :vlax-true)
) ;_ end of and
(foreach att
(append (vlax-invoke item 'GETATTRIBUTES)
(vlax-invoke item 'GETCONSTANTATTRIBUTES)
) ;_ end of append
(vl-catch-all-apply 'vla-put-color (list att acbylayer))
(vl-catch-all-apply
'vla-put-layer
(list att (vla-get-name tmp))
) ;_ end of VL-CATCH-ALL-APPLY
(vl-catch-all-apply
'vla-put-lineweight
(list att aclnwt030)
) ;_ end of VL-CATCH-ALL-APPLY
) ;_ end of foreach
) ;_ end of if
(if (and (vlax-write-enabled-p item)
(wcmatch (vla-get-objectname item) "*Dimension*")
) ;_ end of and
(progn
(vl-catch-all-apply
'vla-put-extensionlinecolor
(list item acbyblock)
) ;_ end of vl-catch-all-apply
(vl-catch-all-apply
'vla-put-textcolor
(list item acbyblock)
) ;_ end of vl-catch-all-apply
(vl-catch-all-apply
'vla-put-dimensionlinecolor
(list item acbyblock)
) ;_ end of vl-catch-all-apply
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ if wcmatch "*|*"

) ;_ vlax-for
(bg:progress-clear)
(bg:progress-init (strcat "־בנאבאעגא‏ בכמךט ...") (/ (vla-get-count (vla-get-blocks doc)) 100))
(setq cnt 0 pbar 0)
;;; ֿנמץמהטלס ןמ בכמךאל
(vlax-for item (vla-get-blocks doc) ;_ end of vla-get-blocks
(if (zerop (rem (setq cnt (1+ cnt)) 100))
(bg:progress (setq pbar (1+ pbar)))
)
(if (and
(eq (vla-get-islayout item) :vlax-false) ;_ םו כטסע
(eq (vla-get-isxref item) :vlax-false) ;_ םו גםורםטו ססכךט
(not (wcmatch (vla-get-name item) "*|*"))
) ;_ end of and
(progn
(vlax-for sub_item item
(vl-catch-all-apply
'(lambda ()

(setq color (vla-get-color sub_item)
Lay (vla-get-layer sub_item) ;_ "*|*"
Lw (vla-get-lineweight sub_item)
) ;_ end of setq
(if (not (wcmatch Lay "*|*")) ;_ןנמןףסךאול גםורםטו ססכךט
(progn
(cond ((eq Lw aclnwtbyblock) nil)
((eq Lw aclnwtbylwdefault)
(setq Lw (max aclnwt025 (getvar "LWDEFAULT")))
)
((eq Lw aclnwtbylayer)
(setq Lw
(vla-get-lineweight
(vla-item (vla-get-layers doc)
Lay
) ;_ end of vla-item
) ;_ end of vla-get-LineWeight
) ;_ end of setq
)
(t nil)
) ;_ end of cond

(cond
((eq color acbylayer) nil)
((eq color acbyblock) nil)
((eq color (vla-get-color (vla-item (vla-get-layers doc) Lay))) ;_ײגוע חאהאם גםמ, םמ סמגןאהאוע ס צגועמ סכמ
;_ַאהאול צגוע ןמסכמ‏
(vl-catch-all-apply 'vla-put-color (list sub_item acbylayer))
)
(t
(setq tmp (vla-item (vla-get-layers doc)
Lay
) ;_ end of vla-item
tmp
(bg:layer-create
(list
(cons "name" (strcat Lay "_C_" (itoa color)))
(cons "color" color)
(cons "lw" Lw)
(cons "lt" (vla-get-linetype tmp))
(cons
"plot"
(if
(eq (vla-get-plottable tmp) :vlax-true)
"y"
"n"
) ;_ end of if
) ;_ end of cons
) ;_ end of list
) ;_ end of _dwgru-layer-create
) ;_ end of setq
(vl-catch-all-apply
'vla-put-color
(list sub_item acbylayer)
) ;_ end of VL-CATCH-ALL-APPLY
(vl-catch-all-apply
'vla-put-layer
(list sub_item (vla-get-name tmp))
) ;_ end of VL-CATCH-ALL-APPLY
;;; Lw םו ענמדאול
(if (and (vlax-write-enabled-p sub_item)
(eq (vla-get-objectname sub_item)
"AcDbBlockReference"
) ;_ end of eq
(eq (vla-get-hasattributes sub_item)
:vlax-true
) ;_ end of eq
) ;_ end of and
(foreach att
(append
(vlax-invoke sub_item 'GETATTRIBUTES)
(vlax-invoke
sub_item
'GETCONSTANTATTRIBUTES
) ;_ end of vlax-invoke
) ;_ end of append
(vl-catch-all-apply
'vla-put-color
(list att acbylayer)
) ;_ end of VL-CATCH-ALL-APPLY
(vl-catch-all-apply
'vla-put-layer
(list att (vla-get-name tmp))
) ;_ end of VL-CATCH-ALL-APPLY
(vl-catch-all-apply
'vla-put-lineweight
(list att aclnwt030)
) ;_ end of VL-CATCH-ALL-APPLY
) ;_ end of foreach
) ;_ end of if
(if (and (vlax-write-enabled-p sub_item)
(wcmatch (vla-get-objectname sub_item)
"*Dimension*"
) ;_ end of wcmatch
) ;_ end of and
(progn
(vl-catch-all-apply
'vla-put-extensionlinecolor
(list sub_item acbyblock)
) ;_ end of vl-catch-all-apply
(vl-catch-all-apply
'vla-put-textcolor
(list sub_item acbyblock)
) ;_ end of vl-catch-all-apply
(vl-catch-all-apply
'vla-put-dimensionlinecolor
(list sub_item acbyblock)
) ;_ end of vl-catch-all-apply
) ;_ end of progn
) ;_ end of if

)
) ;_ end of cond
) ;_ end of progn
) ;_ if wcmatch "*|*"

) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of vlax-for
) ;_ end of progn
) ;_ end of if
) ;_ end of vlax-for
(bg:progress-clear)
(bg:layer-status-restore)
(vl-cmdf "_.Regenall")
) ;_ end of defun

(defun bg:bitset (A B) (= (boole 1 A B) B))
(defun bg:ver () "3.1a")

(if (= (getvar "DWGCODEPAGE") "ANSI_1251")
(progn
(princ (strcat "\nBackground tools v." (bg:ver) " ֽאבונטעו ג ךמלאםהםמי סענמךו:"))
(princ "\nBGLAYDEL - ׃האכוםטו גךכ‏קוםםץ ט חאלמנמזוםםץ סכמוג ס ןנטלטעטגאלט")
(princ "\nBG1BLEXP - ֲחנגאוע בכמךט, סמסעמשטו טח מהםמדמ ןנטלטעטגא (גמחלמזםמ הנףדמדמ בכמךא)")
(princ "\nBGBLEXP - ֲחנגאוע בכמך ט גסו בכמךט, גץמהשטו ג םודמ, ןנוגנאשא גטהטלו אענטבףע ג עוךסע")
(princ "\nBGBLEXP1 - ֲחנגאוע בכמךט 1-דמ ףנמגם, ןנוגנאשא גטהטלו אענטבףע ג עוךסע")
(princ "\nBGBLDYNEXP1 - ֲחנגאוע הטםאלטקוסךטו בכמךט 1-דמ ףנמגם, ןנוגנאשא גטהטלו אענטבףע ג עוךסע")
(princ "\nBGBLEXP1NOATT - ֲחנגאוע בכמךט 1-דמ ףנמגם, ף ךמעמנץ םוע גטהטלץ אענטבףעמג")
(princ "\nBGBLXCLIP - ֿמךאחגאוע ןמהנוחאםםו בכמךט")
(princ "\nBGBLXCLIPEXP - ֲחמנגאע ןמהנוחאםםי בכמך")
(princ "\nBGBLDYN2A - ֿנומבנאחמגגאוע הטםאלטקוסךטו בכמךט ג אםמםטלםו")
(princ "\nBGBLDYN2S - ֿנומבנאחמגגאוע הטםאלטקוסךטו בכמךט ג סעאעטקוסךטו")
(princ "\nBGBLALLDYN2A - ֿנומבנאחמגגאוע ֲֵׁ הטםאלטקוסךטו בכמךט ג אםמםטלםו")
(princ "\nBGBLALLDYN2S - ֿנומבנאחמגגאוע ֲֵׁ הטםאלטקוסךטו בכמךט ג סעאעטקוסךטו")
(princ "\nBGCB - ךמןטנףוע מהםמ טח גץמזהוםטי בכמךא ג בכמך ס םמגל טלוםול. http://www.lee-mac.com&quot;)
(princ "\nBGRB - ןונוטלוםמגגאוע מהםמ טח גץמזהוםטי בכמךא ג בכמך ס םמגל טלוםול. http://www.lee-mac.com&quot;)
(princ "\nM2U - ֿנומבנאחמגאע MINSERT (ּֽ-ֱֻ־ֺ) ג Unnamed בכמך")
(princ "\nM2B - ֿנומבנאחמגאע MINSERT (ּֽ-ֱֻ־ֺ) ג בכמך")
(princ "\nU2B - ֿנומבנאחמגאע UNNAMED ג בכמך")
(princ "\nU2BM - ֿנומבנאחמגאע UNNAMED ג בכמך לםמזוסעגוםםי גבמנ")
(princ "\nUX - ֲחמנגאע UNNAMED בכמך")
(princ "\n=======================================")
(princ "\nBGRGB2ACI - ָחלוםוע צגוע ס RGB םא ACI")
(princ "\nBGAll2RGB - ָחלוםוע ACI צגוע ג ודמ RGB ‎ךגטגאכוםע")
(princ "\nBGCOLOR - ַאהאוע גבנאםםי צגוע גסול מבתוךעאל")
(princ "\nBGCOLORXREF - ּוםוע צגוע גבנאםםץ גםורםטץ סכמך (עמכךמ ג עוךףרול סואםסו)")
(princ "\nBGCOLBL - ׃סעאםמגךא ןמסכמ‏ צגועא ןנטלטעטגמג ןמהמסםמג. ֵסכט צגוע חאהאם גםמ- סמחהאועס םמגי סכמי")
(princ "\nBGResetXRef -ׁבנמס םאסענמוך סכמוג גבנאםםץ גםורםטץ ססכמך םא ףסעאםמגכוםםו ג טסץמהםמל פאיכו")
(princ "\nBGBLCC - ָחלוםוע צגוע גבנאםםץ בכמךמג")
(princ "\nBGENCC - ָחלוםוע צגוע גבנאםםמדמ ‎כולוםעא בכמךא")
(princ "\nBGCATT - ָחלוםוע צגוע אענטבףעמג גבנאםםץ בכמךמג")
(princ "\nBGCBL2 - ָחלוםוע צגוע ג בכמךאץ 2 ט במכוו ףנמגם (גכמזוםםץ בכמךאץ)")
(princ "\nBGBLFIX - ֽמנלאכטחאצט בכמךמג")
(princ "\nBGCFT - ֺמםגונעטנףוע גסו ןמכ ג מבקםי עוךסע")
(princ "\nBGCFTSEL - ךמםגונעטנמגאםטו ןמכוי ג מבקםי עוךסע ג גבנאםםץ ןנטלטעטגאץ")
(princ "\nBGHATCHDEL - ׃האכוםטו רענטץמגךט")
)
(progn
(princ (strcat "\nBackground tools v." (bg:ver) " Type in command line:"))
(princ "\nBGLAYDEL - delete frozen and off layers with objects")
(princ "\nBG1BLEXP - Explode blocks consisting of one primitive thing (it is possible other block)")
(princ "\nBGBLEXP - Explode the block and all blocks entering into it, transforming visible attributes in the text")
(princ "\nBGBLEXP1 - Explode blocks of 1st level, transforming visible attributes in the text")
(princ "\nBGBLDYNEXP1 - Explode dynamic blocks of 1st level, transforming visible attributes in the text")
(princ "\nBGBLEXP1NOATT -Explode blocks of 1st level which do not have visible attributes ")
(princ "\nBGBLXCLIP - show xclip blocks")
(princ "\nBGBLDYN2A - Convert Dynamic Blocks to Anonymous blocks")
(princ "\nBGBLALLDYN2A - Conver ALL Dynamic Blocks to Anonymous")
(princ "\nBGBLALLDYN2S - Conver ALL Dynamic Blocks to Static")
(princ "\nBGBLDYN2S - Convert Dynamic Blocks to Static blocks")
(princ "\nBGBLXCLIP - show xclip blocks")
(princ "\nBGBLXCLIPEXP - explode clipped block")
(princ "\nBGCB - copy a single block reference in the working drawing. http://www.lee-mac.com&quot;)
(princ "\nBGRB - rename a single block reference in the working drawing. http://www.lee-mac.com&quot;)
(princ "\nM2U - Convert MINSERT to Unnamed block")
(princ "\nM2B - Convert MINSERT to block")
(princ "\nU2B - Convert UNNAMED to block")
(princ "\nU2BM - Convert UNNAMED to block multiple selection")
(princ "\nUX - Explode UNNAMED block")
(princ "\n=======================================")
(princ "\nBGRGB2ACI - Changes color from RGB to the corresponding Index Color (ACI)")
(princ "\nBGAll2RGB - Converts the ACI colours of all entities to the RGB TrueColor equivalent")
(princ "\nBGCOLOR - Set a selected color to all objects (WITHOUT XREF)")
(princ "\nBGCOLORXREF - Changes color selected XREF ( ONLY ON A CURRENT SESSION )")
(princ "\nBGCOLBL - Sets the color primitives \"bylayer\". If the color is set to force - Create a new layer")
(princ "\nBGResetXRef -Resets properties of all layers dependent on the selected XREF(s) to those set in the source drawing file(s).")
(princ "\nBGBLCC - Changes color of the chosen blocks")
(princ "\nBGENCC - Changes color of the chosen element of the block")
(princ "\nBGCATT - Changes color of attributes of the chosen blocks")
(princ "\nBGCBL2 - Changes color in blocks 2 and more levels (the nested blocks)")
(princ "\nBGBLFIX - fix (normalize) blocks")
(princ "\nBGCFT - Convert field to text")
(princ "\nBGCFTSEL - Convert field to text in selected objects")
(princ "\nBGHATCHDEL - Remove hatch")
)
)
(princ)

Advertisements