Renamer script...

...will be pretty useless to most people, as it's designed with a very specific task in mind that won't apply to most, but it's taken me months to get it to this stage, and I'd never used any kind of programming code before, so I'm pretty proud of it - thanks to all who helped with it on these forums.
 
Background:
 
We have to export documents from our Hummingbird Document Management System and transfer them to a PC that's on another network.  The problem is Hummingbird exports them using it's own internal numbers/data in the format:
 
<library name>-#<internal doc number>-<library version>-Name_of_file_with_underscores_for_spaces
 
For example:
 
BERTHING_U-#12345-v1-Nuclear_Safety_Broadcast_System_Design.PDF
 
Which I'm sure you'll agree is pretty unreadable, especially if you have lots of files like this.  Also we need to have 3 other fields from within Hummingbird in the new file name, but Hummingbird won't let you choose which field names to export as part of the name.
 
So before my script came into existence, we had to manually rename each file, removing the BERTHING_U-#12345-v1- bit, find the other 3 fields values for that file by looking in Hummingbied, append them to the start of the file name, and remove all underscores.  Remember this was done manually, within Windows Explorer.  And we can do hundreds of files at a time.
 
So my script started as a 6 liner, trying to automate this labourious task a bit.  It grew & grew, it's now 243 lines!  In summary, here's what it does:
 
1) Offer the user to pick a folder where the candidate files for renaming are
 
2) Set some Regular Expressions to find the text, etc, I want to get rid of
 
3) Loop through all the files in the chosen folder, finding any candidates for renaming
 
4) Offer the user the chance to type in the info from the extra 3 fields
 
5) Rename the files
 
6) Once done offer the user the chance to e-mail them or queue them to burn to CD (depending on size)
 
It works very well.  As I said I don't think as a whole that many people will have a use for it, but it's pretty well commented and someone somewhere might find a use for a technique used in it or a section of it
 
For the sake of easier reading, I'll post it in a separate post.
 

 Option Explicit 'Force all variables to be declared
 'Declare all the variables
 Dim fso, File, re, re1, re2, strNewFullName, strNewName, strExtension, strTitle, intHash, intv1
 Dim strSystemMsg, strSystem, strSequenceMsg, strSequence, strRevisionMsg, strRevision, arrSysSeqRev(2)
 Dim strSysSeqRevResult, booExtraInfo, varCancelExtraInfo, intFileCounter, intFileCounter2, strSingPlural
 Dim intDot, strFullPath, intAppend, strDocNo, objShell, booFlag, strSysSeqRev, intArrCount, objApp
 Dim objFolder, objFolderItem, objPath, openfolder, strDesktop, arrFiles(), intSize, objFolder2, nnemail
 Dim strAttach, arrFileList(), filecount, filelist, intArrCount2, emailfiles, burnfiles, cddrive, nntitle
 'Define constants for the BroswForFolder method to work
 Const WINDOW_HANDLE = 0
 Const OPTIONS = &H200
 'Create the FSO, Shell and set some Regular Expressions for parsing the file name.  Also get the path to the current user's desktop
 Set objShell = CreateObject("WScript.Shell")
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set objApp = CreateObject("Shell.Application")
 strDesktop = objShell.SpecialFolders("Desktop")
 Set objFolder = objApp.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", OPTIONS, strDesktop)
 Set re = New RegExp
 Set re1 = New RegExp
 Set re2 = New RegExp
 If objFolder Is Nothing Then Wscript.Quit 'If the user clicks cancel to the BrowseForFolder dialog, then quit
 'Required due to a quirk in the Shell object
 Set objFolderItem = objFolder.Self
 objPath = objFolderItem.Path
 Set objFolder2 = fso.GetFolder(objPath) 'Get the folder for use later working out the size of it
 intFileCounter = 0 'This counter will later be decreased as files are renamed, so the script knows when there's only 1 left to be done
 intFileCounter2 = 0 'This counter will not be decreased as files are renamed, so the script will later know if there were no files to begin with
 intArrCount = 0 'make sure the array is at 0 to begin with
 'Find the bits of the file name I want to change using Regular Expressions
 re.Pattern = "BERTHING(?:_U)?-#\d+-v1-"
 re.IgnoreCase = False
 re1.Pattern = "_+" 'Find all the underscores for changing to spaces
 re1.Global = True
 re2.Pattern = " and " 'Find any occurrences of "and" for changing to "&"
 re2.Global = True
 booExtraInfo = True 'Boolean variable used to determine whether to call up the InputBox code later
 'Loop to count the number of files that are candidates for renaming
 For Each File In fso.GetFolder(objPath).Files
  If re.Test(File.Name) Then intFileCounter = intFileCounter + 1 : intFileCounter2 = intFileCounter2 + 1
 Next
 ReDim arrFiles(intFileCounter2 - 1) 'set the size of the dynamic array
 'Work out the correct syntax for the MsgBox later
 If intFileCounter2 > 1 Then
  strSingPlural = "files"
 Else
  strSingPlural = "file"
 End If
 'Loop through all the files in the chosen folder
 For Each File In fso.GetFolder(objPath).Files
  intAppend = 0 'Set this counter to 0, for use later to append a number to file name where necessary to avoid duplicate names
  booFlag = False 'Boolean variable used to check if any of the files in the folder are candidates for renaming
  'The code below is used later to parse the Hummingbird document number from the original filename
  intHash = InStr(1,File.Name,"#")
  intv1 = InStr(1,File.Name,"-v1")
  If intHash + intv1 <> 0 Then
   strDocNo = Mid(File.Name,intHash+1,intV1-(intHash+1))
  Else
   strDocNo = "Not found"
  End If
  strNewFullName = File.Name 'Store the name of the file in a variable
  strTitle = "File Renamer" 'Title for the InputBox
  strSysSeqRevResult = "" 'Clear this variable ready for use on the next file
  
  'Block of If statements to use the Regular Expressions to build a new file name and store it in a variable
  If re.Test(strNewFullName) Then strNewFullName = re.replace(strNewFullName, "") : booFlag=True
  If re1.Test(strNewFullName) Then strNewFullName = re1.replace(strNewFullName, " ")
  If re2.Test(strNewFullName) Then strNewFullName = re2.replace(strNewFullName, " & ")
    
  If booFlag = True Then 'Only rename files in the folder if they're flagged as meeting one of the first 2 Regular Expressions
   'Used to separate the file name and the extension
   intDot = InStrRev(strNewFullName,".")
   strNewName=Trim(Left(strNewFullName,Len(strNewFullName)-(Len(strNewFullName)-(intDot-1))))
   strExtension=LCase(Right(strNewFullName,Len(strNewFullName)-(intDot-1)))
   'Get the user to type in the System, Sequence and Revision number for the new filename - this info has to be done manually like this,
   'have no way of interrogating Hummingbird for this info.
   'The Hummingbird doc number is shown so the user can go back to Hummingbird and search for this doc number to get the System,
   'Sequence and Revision
   If booExtraInfo = True Then
    strSystemMsg = "Please enter System for: " & VbCRLf & VbCRLf & strNewName & VbCRLf & VbCRLf &_
    "Hummingbird Doc #: " & strDocNo & VbCRLf & VBCRLf & "To omit the System, click Cancel"
    arrSysSeqRev(0) = InputBox(strSystemMsg,strTitle)
    strSequenceMsg = "Please enter Sequence Number for: " & VbCRLf & VbCRLf & strNewName & VbCRLf & VbCRLf &_
    "Hummingbird Doc #: " & strDocNo & VbCRLf & VbCRLf & "To omit the Sequence Number, click Cancel"
    arrSysSeqRev(1) = InputBox(strSequenceMsg,strTitle)
    strRevisionMsg = "Please enter Revision for: " & VbCRLf & VbCRLf & strNewName & VbCRLf & VbCRLf &_
    "Hummingbird Doc #: " & strDocNo & VbCRLf & VbCRLf & "To omit the Revision, click Cancel"
    arrSysSeqRev(2) = InputBox(strRevisionMsg,strTitle)
    'Use the answers from the InputBoxes to build the extra info to be appended to the start of the new file name.
    'If a user enters nothing in the 3 InputBoxes above, a boolean flag is set to stop the script asking for the remaining files.
    'A MsgBox will be used to confirm if the user wants to omit Sys, Seq & Rev no for all remaining files.
    For Each strSysSeqRev In arrSysSeqRev
     If strSysSeqRev <> "" Then strSysSeqRevResult = strSysSeqRevResult & strSysSeqRev & "-"
    Next
    
    If strSysSeqRevResult <> "" Then
     strSysSeqRevResult = Left(strSysSeqRevResult, Len(strSysSeqRevResult)-1)
    Else
     If intFileCounter > 1 Then 'Only ask the following question if there are files left to rename
      varCancelExtraInfo = MsgBox ("You have not entered any System, Sequence & Revision information." & VbCRLf &_
      "Do you want to omit this information for all remaining files?",292,"Warning")
       If varCancelExtraInfo = 6 Then booExtraInfo = False
     End If
    End If
   End If
  
   'Build an array to store the new file name, and rename the file based on what's in the array.
   'If a duplicate is encountered append a number to the end of the file name.
   If strSysSeqRevResult = "" Then 'This block will be used if there was no input in the InputBoxes
    arrFiles(intArrCount) = strNewName & strExtension
    If Not fso.FileExists(objPath & "\" & arrFiles(intArrCount)) Then
     File.Name = arrFiles(intArrCount)
    Else
     Do While fso.FileExists(objPath & "\" & arrFiles(intArrCount)) 
           intAppend = intAppend + 1 
          arrFiles(intArrCount) = strNewName & " (" & intAppend & ")" & strExtension
     Loop
        File.Name = arrFiles(intArrCount)
    End If
   Else 'Append the extra info to the start of the file name if the InputBoxes were used
   
    arrFiles(intArrCount) = UCase(strSysSeqRevResult) & " - " & strNewName & strExtension
    If Not fso.FileExists(objPath & "\" & arrFiles(intArrCount)) Then
     File.Name = arrFiles(intArrCount)
    Else
     Do While fso.FileExists(objPath & "\" & arrFiles(intArrCount)) 
           intAppend = intAppend + 1 
          arrFiles(intArrCount) = UCase(strSysSeqRevResult) & " - " & strNewName & " (" & intAppend & ")" & strExtension
     Loop
        File.Name = arrFiles(intArrCount)
    End If
   End If 
  intFileCounter = intFileCounter - 1 'bring this counter down so the script is eventually aware when there's only 1 file remaining
  intArrCount = intArrCount + 1 'increment the array ready for the next file
  End If
 Next 'Move on to the next file
 'Offer the user the opportunity to open the folder to view any renamed files, and let them know how many were renamed
 If intFileCounter2 = 0 Then 'Used if there were no files meeting the criteria to be renamed
  MsgBox "No files found for renaming.",64,"Finished"
 Else
  openfolder = MsgBox (intFileCounter2 & " " & strSingPlural & " renamed." & VbCRLf & VbCRLf & _
  "Do you want to open the folder to view the files?" & VbCRLf & VbCRLf & _
  "WARNING:  If you click Yes will not have the opportunity to e-mail or burn the files.", 292, "Finished")
  If openfolder = 6 Then
   objShell.Run "explorer " & objPath
   WScript.Quit
  End If
 End If
 'Get the size of the renamed files
 intSize = objFolder2.Size
 Set filelist = objFolder2.Files
 filecount = filelist.Count
 ReDim arrFileList(filecount - 1)
 For Each File In fso.GetFolder(objPath).Files
  arrFileList(intArrCount2) = File.Name
  intArrCount2 = intArrCount2 + 1
 Next
 'If the chosen folder is Navynet, set the defaults for the e-mail Sub
 If objPath = "C:\Documents and Settings\mark.mcrobie\Desktop\Navynet" Then nnemail = "[email=jackie.guthrie@a.dii.mod.uk]jackie.guthrie@a.dii.mod.uk[/email]" : nntitle = "Navynet"
 'Run the e-mail Sub if the size of all the files is less than 5MB, run the burn Sub if greater than 5MB
 If intSize > 0 And intSize < 5000000 Then
  emailfiles = MsgBox ("Total size of files in " & objPath & " is less than 5MB.  Do you want to e-mail them?" & VbCRLf & VbCRLf & _
  "WARNING:  All files will be deleted after e-mailing.", 276, "Finished")
   If emailfiles = 6 Then
   SendAttach
   For Each File In fso.GetFolder(objPath).Files
    File.Delete
   Next
   End If
 ElseIf intSize => 5000000 Then
  burnfiles = MsgBox ("Total size of file in " & objPath & " is 5MB or more.  Do you want to queue them for burning to disc?" & _
  VbCRLf & VBCRLf & "WARNING:  All files will be deleted after queuing for burn.", 276, "Finished")
   If burnfiles = 6 Then
    cddrive = InputBox("Enter the drive letter of your CD/DVD writer." & VbCRLf & VbCRLf & "Enter the letter only, no : or \",strTitle,"F")
    If cddrive = "" Then WScript.Quit
    BurnCD
   For Each File In fso.GetFolder(objPath).Files
    File.Delete
   Next
   End If
 End If
 'Sub to attach the renamed files to a new e-mail message
 Sub SendAttach()
     Dim objOutlook, objMail, strMsg
     Const olMailItem = 0
     Set objOutlook = CreateObject("Outlook.Application")
     Set objMail = objOutlook.CreateItem(olMailItem)
     objMail.To = InputBox ("Enter e-mail address",strTitle,nnemail)
     objMail.Subject = InputBox ("Enter subject",strTitle,nntitle) 
     For Each strAttach In arrFileList
      objMail.Attachments.Add objPath & "\" & strAttach 
  Next 
     objMail.Body = InputBox ("Enter main body text",strTitle)
     objMail.Display 'Use objMail.Display to display before sending, otherwise call objMail.Send to send without reviewing
     Set objMail = Nothing
     Set objOutlook = Nothing
 End Sub
 'Sub to queue files to be burned to CD
 Sub BurnCD()
  Dim strComputer, objRegistry, strKeyPath, strValueName, objWMIService, colFileList, objFile, strCopy, strBurnFolder
  Const HKEY_CURRENT_USER = &H80000001
  strComputer = "."
  Set objRegistry=GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")
  strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
  strValueName = "CD Burning"
  objRegistry.GetStringValue HKEY_CURRENT_USER,strKeyPath,strValueName,strBurnFolder
  Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
  Set colFileList = objWMIService.ExecQuery _
      ("ASSOCIATORS OF {Win32_Directory.Name='" & objPath & "'} Where " _
         & "ResultClass = CIM_DataFile")
  For Each objFile In colFileList
      strCopy = strBurnFolder & "\" & objFile.FileName & "." & objFile.Extension
      objFile.Copy(strCopy)
  Next
  objShell.Run "explorer " & cddrive & ":\"
 End Sub