Excel VBA to sort through AutoCAD Category .ATC files and re-browse GUIDS for tool palate elements based on name with new GUID
Pont is whe n you ahve AutoCAD Palette failes that need rebuilding oit creates a GUID to append to the file name of the palettes-
This opens those files and re-browses the
[FILEPATH]\[PaletteName]_[GUID36].ATC
to use the [PaletteName]
to browse for a new location and GUID attached to a new [palette name]_[NewGUID63].atc.
Without it the images and everything falls apart...
Attribute VB_Name = "AutoCAD_XML"
'open folder... \\corp.ktgy.com\global\Resources\Technology\Autocad\ktgy-2018\ToolCatalog\Categories
''for each file ATC KTGY-Annotation_398C94D2-3F40-44A9-A78F-C9060967DE2F.atc
''Regex find - Build dictionary
''<Url href=
''"\\corp.ktgy.com\global\Resources\Technology\Autocad\ktgy-2018\ToolCatalog\Palettes\Dimensions_3A32B23F-F3A1-4800-8A4A-046358939D5D.atc"
''/>
''For each member of dictionary
''If Filepath exists remove from dictionary
''if it doesnt -
''RE.get first part of filepath out to file name out to the Underscore. HERE-vvvvvvvvvvv
''\\corp.ktgy.com\global\Resources\Technology\Autocad\ktgy-2018\ToolCatalog\Palettes\Dimensions_
''search the tool palette folder for that filename+path
'if more or less than one exists
''disambiguate / Browse for a replacement
''Replace the old path & GUID waith the new one RE.REplace
''Next Member
''next ATC file
Sub CallScanATC()
ScanATC_Files "\\corp.ktgy.com\global\Resources\Technology\Autocad\ktgy-2018\ToolCatalog\Categories" _
, "\\corp.ktgy.com\global\Resources\Technology\Autocad\ktgy-2018\ToolCatalog\Palettes\"
End Sub
Private Sub ScanATC_Files(StrFolderPath As String, FPT As String)
''Pass in source and File PAth Target folders
Dim FSO As New FileSystemObject ''File suystem object to access files/folders
Dim FP As Folder ''Folder to search
Dim Ofile As File ''Order thorugh files in folder
Dim strFile As String ''load file to Regedit
Dim RE As New RegExp ''Regular expressions
Dim MC As MatchCollection ''Re match collection
Dim MA As Match ''match objects
Dim strSourcePat As String ''Rebuild string source mathc for reges
Dim FRF As String ''File replacement FILE
Dim dicFiles As New Collection ''File collection
Dim outfile As TextStream ''Write out XML file
Set FP = FSO.GetFolder(StrFolderPath) ''Set path
If FP Is Nothing Then ''If failed notify and exit
MsgBox "Can't find filepath" & vbCr & vbCr & "Exiting.", vbCritical + vbOKOnly, "File not found"
Exit Sub
End If
If VBA.Dir(FP.Path & "\*.atc") = "" Then ''Nothingto work on - exit
MsgBox "Can't find .ATC files" & vbCr & vbCr & "Exiting.", vbCritical + vbOKOnly, "File not found"
Exit Sub
End If
''path is good - look for ATC files
For Each Ofile In FP.Files
dicFiles.Add Ofile
Next Ofile
For Each Ofile In dicFiles
''if no backup exists- file GUID Characters + (YYYY-MM-DD-HHMM)And if extension is correct
''then search and swap
If Backup(Ofile, FSO) = 1 _
And FSO.GetExtensionName(Ofile) = "atc" _
Then
''Run search and swap
strFile = "" ''Initialize string
strFile = Ofile.OpenAsTextStream.ReadAll ''Read in file
With RE ''Regular epressions
.MultiLine = True
.IgnoreCase = True
.Global = True
.Pattern = "(<Url.href=\"")(\\\\.*)?\\(.*)?_(.*\.atc)\""\/>"
Set MC = .Execute(strFile)
End With
For Each MA In MC ''Use pattern matches as a loop
FRP = "" ''null
''Select case if 1 great it <1 not found if > 1 need to select which too use.
Select Case FileCount(FPT & MA.SubMatches(2) & "_*.atc") ''targt Name of palette
Case Is < 1
strMsg = strMsg & "Skipping/Cannot find: " & FPT
Case FC > 1
MsgBox "More than one exists - write out code to select"
Stop
''browse to pick which to replace
Case Else
FRP = FPT & Dir(FPT & MA.SubMatches(2) & "_*.atc")
End Select
'''Find and replace the original wiht the new...
'Search and replace file paths - escape search values to literals
strSourcePat = MA.SubMatches(1) & "\" & MA.SubMatches(2) & "_" & MA.SubMatches(3)
strSourcePat = Replace(strSourcePat, "\", "\\", 1, -1, vbTextCompare) ''Escape backslash
strSourcePat = Replace(strSourcePat, ".", "\.", 1, -1, vbTextCompare) ''Escape dot
strSourcePat = Replace(strSourcePat, "/", "\/", 1, -1, vbTextCompare) ''Escape Front Slash
strSourcePat = Replace(strSourcePat, "$", "\$", 1, -1, vbTextCompare) ''Escape $
''escape the characters int eh find...
''Replace(FRP, "\", "\\", 1, -1, vbTextCompare)
RE.Pattern = strSourcePat
If Not RE.test(strFile) Then
MsgBox "Error finding original sring"
Stop
End If
strFile = RE.Replace(strFile, FRP) ''Reset strfile to replaced value
Next
Set outfile = Nothing
Set outfile = FSO.CreateTextFile(Ofile.Path)
outfile.Write (strFile)
outfile.Close
End If
Next Ofile
End Sub
Function FileCount(strFP As String) As Integer
Dim str As String
''If Right(strFP, 1) <> "\" Then strFP = strFP & "\"
str = VBA.Dir(strFP)
Do While str > ""
FileCount = FileCount + 1
str = VBA.Dir
Loop
End Function
Function Backup(ByRef Ofile As File, ByRef FSO) As Integer
'Dim fso As New FileSystemObject
Dim FNBK As String
FNBK = Ofile.ParentFolder.Path & "\" & FSO.GetBaseName(Ofile) & "(" & Format(Ofile.DateCreated, "YYYY-MM-DD-hhmm") & ").atc"
If FSO.FileExists(FNBK) Then ''file already exists
Backup = -1 ''backup failed- already exists
ElseIf FSO.GetBaseName(Ofile) Like _
left(FSO.GetBaseName(Ofile), 36) & "*(????-??-??-????)" _
Then ''file mathing base+pattern exists - backup exists
Backup = -1
Else
FSO.CopyFile Ofile, FNBK, False
Backup = 1
End If
End Function
Comments
Post a Comment