;;; Saved from: http://www.theswamp.org/index.php?topic=17659.0;all

(defun c:MTS (/ ActDoc StyCol tempObjName StyName tempList StyObjList DataList Pos DimData tempData StyList FontList DiaLoad
ChangeDimTxt DimTxtIndex ChangeTxt TxtIndex *error* ChangeList)
; Merge text styles.
; Sub's (not in current file) 'MyGetXData 'MySetXData 'StrParse
; 07/18/07 Corrected the issue with dimension styles.
; 07/19/07 Added the option to remove items from the merge list.
; 07/20/07 Added the ability to create text styles from the dialog.
; 07/23/07 Added code to find the default windows directory for fonts. Code provided by Michael Puckett.
; 07/24/07 Added code to get the style name of the font, not just the file name, for true type fonts.
; Code provided by Michael Puckett.
; 07/27/07 Added the abiltiy to change the two system variables that deal with text styles (DimTxSty, TextStyle).
; 08/01/07 Added the ability to delete the styles that are going to be merged and changed the system variables from.
; Added the ability to change the fonts associated with dimension and leader overrides.
; Rewrote code (to look better, and have some better variable names) .

(defun *error* (msg)

(if ActDoc (vla-EndUndoMark ActDoc))
(prompt (strcat "\n Error--> " msg))
)
;-------------------------------------------------------------------------------------
(defun StrParse (String Seperator / Pos1 Pos2 NewStrList)
;|
Seperator a string (making a list of stings) at a given
string value
ie: (StrParse "1,1,0" ",")
returns: ("1" "1" "0")
Written when I couldn't find it on the web
By: Tim Willey 11/15/2004
|;

(setq Pos2 1)
(while (setq Pos1 (vl-string-search Seperator String Pos1))
(if (= Pos2 1)
(setq NewStrList (cons (substr String Pos2 Pos1) NewStrList))
(setq NewStrList (cons (substr String Pos2 (- (1+ Pos1) Pos2)) NewStrList))
)
(setq Pos2 (1+ (+ (strlen Seperator) Pos1)))
(setq Pos1 (+ Pos1 (strlen Seperator)))
)
(reverse (setq NewStrList (cons (substr String Pos2) NewStrList)))
);-----------------------------------------------------------------------------
(defun MySetXData (Obj CodeList DataList / )
; Sets XData to an object. Must number in code list must be 1001

(vla-SetXData Obj
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbInteger
(cons 0 (1- (length CodeList)))
)
CodeList
)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbVariant
(cons 0 (1- (length Datalist)))
)
DataList
)
)
)
)
;-----------------------------------------------------------------------------
(defun MyGetXData (Obj DataName / CodeType DataType)
; Retrive XData for an object

(vla-GetXData
Obj
(if DataName
DataName
""
)
'CodeType
'DataType
)
(if (and CodeType DataType)
(mapcar
'(lambda (a b)
(cons a (variant-value b))
)
(safearray-value CodeType)
(safearray-value DataType)
)
)
)
;-------------------------------------------------------------------------------------
(defun UpdateShowMerge (/ ToMerge MergeTo tempChangeList)

(if
(and
(/= (setq ToMerge (get_tile "ToMerge")) "")
(/= (setq MergeTo (get_tile "MergeTo")) "")
)
(progn
(foreach strNum (StrParse ToMerge " ")
(setq tempChangeList
(cons
(cons
(atoi strNum)
(atoi MergeTo)
)
tempChangeList
)
)
)
(start_list "ShowMerge" 2)
(foreach lst tempChangeList
(add_list
(strcat
(car (nth (car lst) StyObjList))
"\t->\t"
(car (nth (cdr lst) StyList))
)
)
)
(end_list)
(setq ChangeList (append ChangeList tempChangeList))
)
)
)
;----------------------------------------------------------------------------------------------------------------------------
(defun ProceedButtonPressed (/ ErrCnt Obj tempEntData ObjList tempData StyEnt DimTxStyName TextStyleName DelTog DataList Pos)

(setq DelTog (get_tile "DeleteTgl"))
(done_dialog 1)
(setq ErrCnt 0)
(foreach pair ChangeList
(setq ObjList (nth (car pair) StyObjList))
(foreach Obj (cdr ObjList)
(if (not (vlax-erased-p Obj))
(cond
((vl-position (vla-get-ObjectName Obj) '("AcDbDimStyleTableRecord" "AcDbLinetypeTableRecord"))
(setq tempEntData (entget (vlax-vla-object->ename Obj)))
(foreach lst tempEntData
(if
(and
(equal (type (cdr lst)) 'ENAME)
(setq tempData (entget (cdr lst)))
(= (cdr (assoc 0 tempData)) "STYLE")
(= (cdr (assoc 2 tempData)) (car ObjList))
)
(progn
(setq StyEnt
(vlax-vla-object->ename
(vla-Item
StyCol
(car
(nth (cdr pair) StyList)
)
)
)
)
(if
(not
(entmod
(subst
(cons (car lst) StyEnt)
(assoc (car lst) tempEntData)
tempEntData
)
)
)
(prompt (strcat "\n Dimension style: " (vla-get-Name Obj) " did not update text style."))
)
)
)
)
)
(
(or
(wcmatch (vla-get-ObjectName Obj) "*Dimension")
(= (vla-get-ObjectName Obj) "AcDbLeader")
)
(setq DataList (MyGetXData Obj "ACAD"))
(setq Pos (vl-position '(1070 . 340) DataList))
(setq DataList
(subst
(cons
1005
(vla-get-Handle
(vla-Item StyCol
(car
(nth (cdr pair) StyList)
)
)
)
)
(nth (1+ Pos) DataList)
DataList
)
)
(MySetXData Obj (mapcar 'car DataList) (mapcar 'cdr DataList))
)
(t
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-StyleName
(list
Obj
(car
(nth (cdr pair) StyList)
)
)
)
)
(setq ErrCnt (1+ ErrCnt))
)
)
)
)
)
)
(if ChangeDimTxt
(progn
(setq DimTxStyName (getvar "DimTxSty"))
(setvar "DimTxSty" (car (nth DimTxtIndex StyList) ))
)
)
(if ChangeTxt
(progn
(setq TextStyleName (getvar "TextStyle"))
(setvar "TextStyle" (car (nth TxtIndex StyList)))
)
)
(if (= DelTog "1")
(progn
(foreach pair ChangeList
(if
(not
(vl-catch-all-error-p
(setq tempStyObj
(vl-catch-all-apply
'vla-Item
(list
StyCol
(car
(nth (car pair) StyObjList)
)
)
)
)
)
)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-Delete (list tempStyObj)))
(prompt (strcat "\n Could not delete style \"" (car (nth (car pair) StyObjList)) "\""))
)
)
)
(if
(and
DimTxStyName
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-Item (list StyCol DimTxStyName))))
)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-Delete (list (vla-Item StyCol DimTxStyName))))
(prompt (strcat "\n Could not delete style \"" DimTxStyName "\""))
)
)
(if
(and
TextStyleName
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-Item (list StyCol TextStyleName))))
)
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-Delete (list (vla-Item StyCol TextStyleName))))
(prompt (strcat "\n Could not delete style \"" TextStyleName "\""))
)
)
)
)
(if (> ErrCnt 0)
(prompt (strcat "\n Could not update " (itoa ErrCnt) " entities."))
)
)
;---------------------------------------------------------------------------------------
(defun RemoveButtonPressed (/ cnt NumStr NumList tempList)

(setq cnt 0)
(if (/= (setq NumStr (get_tile "ShowMerge")) "")
(progn
(setq NumList (read (strcat "(" NumStr ")")))
(while (\t"
(car (nth (cdr lst) StyList))
)
)
)
(end_list)
(mode_tile "RemoveBtn" 1)
)
)
)
;------------------------------------------------------------------------
(defun CreateButtonPressed (/ NewSty tempList tempDimStyName tempTextStyleName)

(if ChangeDimTxt
(setq tempDimStyName
(car
(nth
(atoi (get_tile "DimTxStyList"))
StyList
)
)
)
)
(if ChangeTxt
(setq tempTextStyleName
(car
(nth
(atoi (get_tile "TextStyleList"))
StyList
)
)
)
)
(setq NewSty (vla-Add StyCol (get_tile "StyleName")))
(setq tempList (nth (atoi (get_tile "FontListbox")) FontList))
(vla-put-FontFile NewSty (cdr tempList))
(setq StyList nil)
(vlax-for Sty StyCol
(setq StyName (vla-get-Name Sty))
(if
(and
(not (vl-string-search "|" StyName))
(/= StyName "")
)
(setq StyList
(cons
(cons
StyName
(last
(StrParse
(vla-get-FontFile Sty)
"\\"
)
)
)
StyList
)
)
)
)
(setq StyList
(vl-sort
StyList
'(lambda (a b)
(ename Dim)))
(foreach pair DimData
(if
(and
(equal (type (cdr pair)) 'ENAME)
(setq tempData (entget (cdr pair)))
(= (cdr (assoc 0 tempData)) "STYLE")
(setq StyName (cdr (assoc 2 tempData)))
(not (vl-string-search "|" StyName))
)
(if (setq tempList (assoc StyName StyObjList))
(setq StyObjList (subst (append tempList (list Dim)) tempList StyObjList))
(setq StyObjList (cons (list StyName Dim) StyObjList))
)
)
)
)
(setq StyObjList
(vl-sort
StyObjList
'(lambda (a b)
(< (strcase (car a)) (strcase (car b)))
)
)
)
(vlax-for Sty StyCol
(setq StyName (vla-get-Name Sty))
(if
(and
(not (vl-string-search "|" StyName))
(/= StyName "")
)
(setq StyList
(cons
(cons
StyName
(last
(StrParse
(vla-get-FontFile Sty)
"\\"
)
)
)
StyList
)
)
)
)
(setq StyList
(vl-sort
StyList
'(lambda (a b)
(< (strcase (car a)) (strcase (car b)))
)
)
)
(foreach path (StrParse (getenv "ACAD") ";")
(foreach font (append (vl-directory-files path "*.shx" 1) (vl-directory-files path "*.ttf" 1))
(if (not (assoc font FontList))
(setq FontList (cons (cons font (strcat path "\\" font)) FontList))
)
)
)
(setq FontList
(vl-sort
(append
FontList
(_GetFontIndex)
)
'(lambda (a b)
(< (strcase (car a)) (strcase (car b)))
)
)
)
(setq DiaLoad (load_dialog "MyDialogs.dcl"))
(if (new_dialog "MergeTextStyles" DiaLoad)
(progn
(mode_tile "RemoveBtn" 1)
(start_list "ToMerge" 3)
(foreach lst StyObjList
(add_list
(strcat
(car lst)
"\t[ "
(last
(StrParse
(vla-get-FontFile
(vla-Item
StyCol
(car lst)
)
)
"\\"
)
)
" ]\t[ "
(itoa (1- (length lst)))
" ]"
)
)
)
(end_list)
(start_list "MergeTo" 3)
(foreach pair StyList
(add_list (strcat (car pair) "\t[ " (cdr pair) " ]"))
)
(end_list)
(start_list "DimTxStyList" 3)
(foreach pair StyList
(add_list (car pair))
)
(end_list)
(start_list "TextStyleList" 3)
(foreach pair StyList
(add_list (car pair))
)
(end_list)
(start_list "FontListbox")
(foreach pair FontList
(add_list (car pair))
)
(end_list)
(set_tile "Text01" (strcat "DimTxSty = " (getvar "DimTxSty")))
(set_tile "Text02" (strcat "TextStyle = " (getvar "TextStyle")))
(set_tile "DimTxStyList" (itoa (vl-position (assoc (getvar "DimTxSty") StyList) StyList)))
(set_tile "TextStyleList" (itoa (vl-position (assoc (getvar "TextStyle") StyList) StyList)))
(action_tile "DimTxStyList"
"(if (equal $reason 1)
(setq
ChangeDimTxt T
DimTxtIndex (atoi $value)
)
)"
)
(action_tile "TextStyleList"
"(if (equal $reason 1)
(setq
ChangeTxt T
TxtIndex (atoi $value)
)
)"
)
(action_tile "ShowMerge"
"(if (= $value \"\")
(mode_tile \"RemoveBtn\" 1)
(mode_tile \"RemoveBtn\" 0)
)"
)
(action_tile "RemoveBtn" "(RemoveButtonPressed)")
(action_tile "MergeBtn" "(UpdateShowMerge)")
(action_tile "ProBtn" "(ProceedButtonPressed)")
(action_tile "CreateBtn" "(CreateButtonPressed)")
(action_tile "CanBtn" "(done_dialog 0)")
)
)
(start_dialog)
(vla-EndUndoMark ActDoc)
(princ)
)

(c:mts)

********** MyDialogs.dcl *********
UnBlank : dialog { label = "UnBlank" ; width = 40 ; height = 27 ;
: row
{
: list_box { label = "Select items to unblank." ; key = "listbox1" ; width = 25 ; multiple_select = false ;}
: column {
: spacer {}
: column {
:spacer {}
: button { label = "UnBlank" ; key = "UnBlank1" ; width = 1 ; fixed_width = true ; }
: toggle { label = "Zoom when UnBlanking?" ; key = "Tog1" ; value = 1 ; }
: button { label = "Zoom extents" ; key = "Zoom1" ; width = 1 ; fixed_width = true ; }
: spacer {}
}
: button { label = "Draw Boundry Box" ; key = "BB1" ; width = 1 ; fixed_width = true ; }
: button { label = "Re-Blank" ; key = "ReBlank1" ; width = 1 ; fixed_width = true ; }
: button { label = "UnBlank All" ; key = "UnBlank2" ; width = 1 ; fixed_width = true ; }
: button { label = "Done" ; key = "Cancel" ; is_cancel = true ; width = 1 ; fixed_width = true ; }
: spacer {}
}
}
}
//-----------------------------------------------------------------------------------------

SingleSelect : dialog{ label = "Select Item";
: list_box { key = "listbox"; width = 55; height = 25; }
: toggle { key = "toggle1"; }
: text { key = "text1"; }
: row {
: spacer { width = 1; }
: button { label = "OK"; is_default = true; allow_accept = true; key = "accept"; width = 8; fixed_width = true; }
: button { label = "Cancel"; is_cancel = true; key = "cancel"; width = 8; fixed_width = true; }
: spacer { width = 1;}
}
}
//-------------------------------------------------------------------------------------------

MultiSelect : dialog{ label = "Select Item";
: list_box { key = "listbox"; width = 55; height = 25; multiple_select = true; }
: toggle { key = "toggle1"; }
: text { key = "text1"; }
: row {
: spacer { width = 1; }
: button { label = "OK"; is_default = true; allow_accept = true; key = "accept"; width = 8; fixed_width = true; }
: button { label = "Cancel"; is_cancel = true; key = "cancel"; width = 8; fixed_width = true; }
: spacer { width = 1;}
}
}
//-------------------------------------------------------------------------------------------

XrefRe : dialog {label = "Xref RePath and ReName."; width = 100; height = 22;

: row {
: list_box { label = "Drawings (Xref's)"; key = "DwgList"; width = 25; height = 17;}
: column { height = 10;
: spacer {}
: boxed_column {
: text { key = "text1"; }
: edit_box { label = "New name for Xref."; key = "NewName"; width = 20; }
: boxed_column { label = "Path type.";
: radio_row { key = "PathType"; width = 20;
: radio_button { label = "Relative"; key = "PathRel"; }
: radio_button { label = "Full"; key = "PathFull"; }
: radio_button { label = "None"; key = "PathNone"; value = 1; }
}
: edit_box { label = "Relative path:"; key = "Path"; width = 20; }
}
: row {
: spacer {}
: button { label = "v Proceed v"; key = "Proceed"; width = 10;}
: spacer {}
}
}
: boxed_column {
: list_box { label = "Xref names: Old to New"; key = "XrefList"; width = 22; height = 7; tabs = "10";}
: row {
: spacer {}
: button { label = "Remove selection"; key = "Remove"; fixed_width = true; }
: spacer {}
}
}
}
}
: row {
: spacer {}
: button { label = "Process current directory"; key = "Accept"; is_default = true; allow_accept = true; width = 8; fixed_width = true; }
: button { label = "Select new directory"; key = "NewDir"; width = 8; fixed_width = true; }
: button { label = "Cancel"; key = "Cancel"; is_cancel = true; width = 8; fixed_width = true; }
: spacer {}
}
}

//---------------------------------------------------------------------------------------

MyPropsTest : dialog { label = "Properties to edit.";
: text { label = "Thanks Michael Puckett!! @ http://www.theswamp.org"; }
: column {
: list_box { label = "List of properties to modify"; key = "PropsListbox"; height = 25; width = 80; tabs = 40;}
: text { key = "TextLabel"; }
: edit_box { key = "PropsEditbox"; }
: row {
: spacer {}
: button { label = "Pick point"; key = "PickPt"; }
: button { label = "Pick from list"; key = "PickList"; }
: button { label = "Help"; key = "HelpProp"; }
: spacer {}
}
: row {
: spacer {}
: button { label = "Apply"; key = "accept"; allow_accept = true; is_default = true; }
: button { label = "Done"; key = "cancel"; is_cancel = true; }
: spacer {}
}
: text { key = "TextResults"; }
}
}

//-------------------------------------------------------------------------------------------

MyPropsList : dialog { label = "Select item from list.";
: list_box { key = "PropsListbox2"; height = 20; width = 40; }
: button { label = "Cancel"; key = "cancel"; is_cancel = true; }
}

//--------------------------------------------------------------------------------------------

AttListDialog : dialog { label = "Attribute tags for blocks selected.";
: column {
: list_box { label = "Attribute tags Number of attribute(s)."; key = "AttListbox"; width = 60; height = 20; tabs = 30; }
: row {
: text { key = "AttTextLabel"; }
: edit_box { key = "AttEditbox"; }
: button { label = "Pick Ext."; key = "PickExisting"; width = 10; fixed_width = true; }
}
: row {
: button { label = "List Prompts"; key = "PromptList"; }
: button { label = "Apply"; key = "Accept"; }
: button { label = "Done"; key = "Cancel"; is_cancel = true; }
}
}
}

//-------------------------------------------------------------------------------------------

MergeTextStyles : dialog { label = "Merge text styles [ v3.0 ]";
: row {
: list_box { label = "Styles found in use."; key = "ToMerge"; width = 60; height = 15; tabs = 23; multiple_select = true; }
: column {
: spacer {}
: button { label = "Merge"; key = "MergeBtn"; width = 10; }
: spacer {}
: button { label = "Remove"; key = "RemoveBtn"; width = 10; }
}
: list_box { label = "Styles to merge to."; key = "MergeTo"; width = 40; height = 15; tabs = 23; }
}
: list_box { label = "Merge list"; key = "ShowMerge"; width = 60; height = 10; tabs = 40; multiple_select = true; }
: row { label = "Creat new style";
: edit_box { label = "Style name:"; key = "StyleName"; }
: popup_list { label = "Select font"; key = "FontListbox"; width = 50; }
: button { label = "Create"; key = "CreateBtn"; width = 15; fixed_width = true; }
}
: spacer {}
: row { label = "Current system variables";
: column {
: row {
: text { key = "Text01"; }
: popup_list { label = "Select new text style"; key = "DimTxStyList"; }
}
: row {
: text { key = "Text02"; }
: popup_list { label = "Select new text style"; key = "TextStyleList"; }
}
}
}
: row {
: toggle { label = " Delete style(s) after merge?"; key = "DeleteTgl"; value = "1"; }
: button { label = "Proceed"; key = "ProBtn"; is_accept = true; }
: button { label = "Cancel"; key = "CanBtn"; is_cancel = true; }
}
}

Advertisements