0 Members and 3 Guests are viewing this topic.
item_common.dbritem_epic.dbritem_legendary.dbr
item_common.dbritem_epic.dbritem_legendary.dbrarmor_common.dbrarmor_epic.dbrarmor_legendary.dbr
Here's an example :There would be two parameters : the tag to search for, and the tag to replace it with.A folder contains those .dbrs :Code: [Select]item_common.dbritem_epic.dbritem_legendary.dbrI want to copy those files, and rename their copy by replacing the tag "item" with "armor". As a result, the content of the folder after executing the code would look like :Code: [Select]item_common.dbritem_epic.dbritem_legendary.dbrarmor_common.dbrarmor_epic.dbrarmor_legendary.dbr
Sub CopyandRename()Dim wd As DocumentDim myPath As StringDim myFile As StringDim myExtension As StringDim FldrPicker As FileDialogApplication.ScreenUpdating = False Restart: Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show = 0 Then myPath = "" myPath = .SelectedItems(1) & "\" If myPath = "" Then GoTo NextCode End WithNextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings myExtension = "item_*.dbr" myFile = Dir(myPath & myExtension) Do While myFile <> "" Set wd = Word.Documents.Open(FileName:=myPath & myFile) DoEvents If myFile = "item_common.dbr" Then ActiveDocument.SaveAs2 myPath & "armor_common.dbr" ElseIf myFile = "item_epic.dbr" Then ActiveDocument.SaveAs2 myPath & "armor_epic.dbr" ElseIf myFile = "item_legendary.dbr" Then ActiveDocument.SaveAs2 myPath & "armor_legendary.dbr" End If ActiveWindow.Close DoEvents myFile = Dir Loop GoTo RestartResetSettings: MsgBox "Task Complete!" Application.ScreenUpdating = TrueEnd Sub
myExtension = "item_*.dbr" myFile = Dir(myPath & myExtension) Do While myFile <> "" Set wd = Word.Documents.Open(FileName:=myPath & myFile) DoEvents If myFile = "item_common.dbr" Then ActiveDocument.SaveAs2 myPath & "armor_common.dbr" ElseIf myFile = "item_epic.dbr" Then ActiveDocument.SaveAs2 myPath & "armor_epic.dbr" ElseIf myFile = "item_legendary.dbr" Then ActiveDocument.SaveAs2 myPath & "armor_legendary.dbr" End If
Sub CopyandRename()Dim myPath As StringDim myFile As StringDim myExtension As StringDim FldrPicker As FileDialogDim MyLength As LongDim MyCopy As StringDim MyText As StringDim message As VariableDim fso As ObjectDim MyNewFile As StringSet fso = CreateObject("Scripting.FileSystemObject")Application.ScreenUpdating = False Result = MsgBox("This program will copy and rename .dbr files that you specify. Press OK to continue or Cancel to leave", vbOKCancel)If Result = vbCancel Then Exit SubRestart: Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)Result = MsgBox("Pick the folder you want to start in or click Cancel if you are done", vbOKCancel)If Result = vbCancel Then Exit Sub With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show = 0 Then GoTo NextCode myPath = .SelectedItems(1) & "\" If myPath = "" Then GoTo NextCode End WithNextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings myExtension = "*.dbr" myFile = Dir(myPath & myExtension) Check1 = InputBox("What is the word that exists in all files you want to check for? i.e. common", , "common") If Check1 = vbNullString Or Check1 = "" Then Result = MsgBox("Clicking Cancel or leaving the text box empty exits this program") Exit Sub End If Check2 = InputBox("What is the next word that exists in all files you want to check for? i.e. epic", , "epic") If Check2 = vbNullString Or Check2 = "" Then Result = MsgBox("Clicking Cancel or leaving the text box empty exits this program") Exit Sub End If Check3 = InputBox("What is the next word that exists in all files you want to check for? i.e legendary", , "legendary") If Check3 = vbNullString Or Check3 = "" Then Result = MsgBox("Clicking Cancel or leaving the text box empty exits this program") Exit Sub End If Check4 = InputBox("What is the word you want to add to the beginning of the file name? i.e armor_. The resulting file will look like ""armor_common.dbr"" be sure to include the underscore or any other characters", , "armor_") If Check4 = vbNullString Or Check4 = "" Then Result = MsgBox("Clicking Cancel or leaving the text box empty exits this program") Exit Sub End If Do While myFile <> "" If myFile Like "*" & Check1 & "*.dbr" Then MyLength = InStr(1, myFile, Check1) - 1 MyText = Left(myFile, MyLength) MyCopy = Replace(myFile, MyText, Check4) MyNewFile = myPath & MyCopy fso.copyfile myPath & myFile, MyNewFile ElseIf myFile Like "*" & Check2 & "*.dbr" Then MyLength = InStr(1, myFile, Check2) - 1 MyText = Left(myFile, MyLength) MyCopy = Replace(myFile, MyText, Check4) MyNewFile = myPath & MyCopy fso.copyfile myPath & myFile, MyNewFile ElseIf myFile Like "*" & Check3 & "*.dbr" Then MyLength = InStr(1, myFile, Check3) - 1 MyText = Left(myFile, MyLength) MyCopy = Replace(myFile, MyText, Check4) MyNewFile = myPath & MyCopy fso.copyfile myPath & myFile, MyNewFile End If DoEvents myFile = Dir Loop GoTo RestartResetSettings: MsgBox "Task Complete!" Application.ScreenUpdating = TrueEnd Sub