Renamer script...

Forums

My Profile

Inbox

Address Book

My Subscription

My Forums

Renamer script...

Logged in as: Guest

arrSession:exec spGetSession 2,16,45152

	Active Users: There are 0 members and 0 guests.
	Users viewing this topic: none

Printable Version

All Forums >> [Scripting] >> Post a VBScript >> Renamer script...
Do you like VisualBasicScript.com? Link to us and help spread the word about our forum. Thanks!

Page: [1]

Message

<< Older Topic Newer Topic >>

Renamer script... - 3/28/2007 8:23:01 PM

markmcrobie

Posts: 314
Score: 0
Joined: 12/12/2006
Status: offline

...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.

Post #: 1

RE: Renamer script... - 3/28/2007 8:23:27 PM

markmcrobie

Posts: 314
Score: 0
Joined: 12/12/2006
Status: offline

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

(in reply to markmcrobie)