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