Rename a batch of files

[Greg Maxey]

Hi,

I am trying to combine some code that Jay Freedman and Doug Robbins have
posted with the object of renaming a batch of files. The renamed files
should be named with the first couple of words in the test.

The files are all located in C:\Text an named 1.doc, 2.doc, 3.doc etc.

Here is my code, followed by problems I can't resolve:

Option Explicit
Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim fn As String
Dim rg As Range

PathToUse = "C:\Test\"
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
Set myDoc = Documents.Open(PathToUse & myFile)
With ActiveDocument
Set rg = .Words(1)
rg.End = .Words(min(9, .Words.Count - 1)).End
fn = Trim(rg.Text) & ".doc"
fn = Replace(fn, "\", "")
fn = Replace(fn, ":", "")
fn = Replace(fn, """", "")
fn = Replace(fn, vbCr, "")
fn = Replace(fn, vbTab, "")
End With
With Dialogs(wdDialogFileSaveAs)
.Name = "C:\Documents\tests\" & fn
.Show
'Trying to use SendKeys to represent ALT+S and save the file. Isn't
working
SendKeys "%s"
End With
myDoc.Close SaveChanges:=wdSaveChanges
myFile = Dir$()
Wend
End Sub
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function

Problems:

1) I can't get the SendKeys statement to duplicate ALT+s which completes
the save and closes the dialog box. I must manually click ALT+s or click
the save button to step through the macro. How do I get SendKeys to work?

2) For some reason the While statement repeats the first saved file. I mean
1.doc opens and is saved as say One Little Indian. Then 2.doc is saved as
Two Little Indians, then 3.doc as Three Little Indians. For some reason One
Little Indian.doc opens with the SaveAs One Little Indian dialog displayed.
Any ideas why?

3) The original 1.doc 2.doc and 3.doc files remain in the directory. Can
these be deleted as part of the VBA code?

Thanks All.

 

[Jean-Guy Marcil]

Greg Maxey was telling us:
Greg Maxey nous racontait que :

Hi,

I am trying to combine some code that Jay Freedman and Doug Robbins
have posted with the object of renaming a batch of files. The
renamed files should be named with the first couple of words in the
test.
The files are all located in C:\Text an named 1.doc, 2.doc, 3.doc etc.

Here is my code, followed by problems I can't resolve:

Option Explicit
Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim fn As String
Dim rg As Range

PathToUse = "C:\Test\"
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
Set myDoc = Documents.Open(PathToUse & myFile)
With ActiveDocument
Set rg = .Words(1)
rg.End = .Words(min(9, .Words.Count - 1)).End
fn = Trim(rg.Text) & ".doc"
fn = Replace(fn, "\", "")
fn = Replace(fn, ":", "")
fn = Replace(fn, """", "")
fn = Replace(fn, vbCr, "")
fn = Replace(fn, vbTab, "")
End With
With Dialogs(wdDialogFileSaveAs)
.Name = "C:\Documents\tests\" & fn
.Show
'Trying to use SendKeys to represent ALT+S and save the file. Isn't
working
SendKeys "%s"
End With
myDoc.Close SaveChanges:=wdSaveChanges
myFile = Dir$()
Wend
End Sub
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function

Problems:

1) I can't get the SendKeys statement to duplicate ALT+s which
completes the save and closes the dialog box. I must manually click
ALT+s or click the save button to step through the macro. How do I
get SendKeys to work?

Avoid SendKeys if you can (It is borderline hacking and is not always
reliable...)
In this case, it is easy to avoid.
Try this instead:

'_______________________________________
Option Explicit
'_______________________________________
Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim NewName As String
Dim OldName As String
Dim rg As Range

PathToUse = "X:\Test\Batch\"

myFile = Dir$(PathToUse & "*.doc")

While myFile <> ""
Set myDoc = Documents.Open(FileName:=PathToUse & myFile, Visible:=False)
With myDoc
OldName = .FullName
Set rg = .Words(1)
rg.End = .Words(min(9, .Words.Count - 1)).End
NewName = Trim(rg.Text) & ".doc"
NewName = Replace(NewName, "\", "")
NewName = Replace(NewName, ":", "")
NewName = Replace(NewName, """", "")
NewName = Replace(NewName, vbCr, "")
NewName = Replace(NewName, vbTab, "")

.Close SaveChanges:=wdSaveChanges
End With

Name OldName As PathToUse & NewName

myFile = Dir$()
Wend

End Sub
'_______________________________________

'_______________________________________
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function
'_______________________________________

No need to fuss around with the Save As dialog.
Why don't you use the SaveAs method instead?

'_______________________________________
Option Explicit
Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim NewName As String
Dim OldName As String
Dim rg As Range

PathToUse = "X:\Test\Batch\"

myFile = Dir$(PathToUse & "*.doc")

While myFile <> ""
Set myDoc = Documents.Open(FileName:=PathToUse & myFile, Visible:=False)
With myDoc
OldName = .FullName
Set rg = .Words(1)
rg.End = .Words(min(9, .Words.Count - 1)).End
NewName = Trim(rg.Text) & ".doc"
NewName = Replace(NewName, "\", "")
NewName = Replace(NewName, ":", "")
NewName = Replace(NewName, """", "")
NewName = Replace(NewName, vbCr, "")
NewName = Replace(NewName, vbTab, "")

.SaveAs PathToUse & NewName
.Close wdSaveChanges
End With

Kill OldName

myFile = Dir$()
Wend

End Sub
'_______________________________________

BUt see point #2, or you will delete a file (The one that gets treated
twice)!

2) For some reason the While statement repeats the first saved file. I
mean 1.doc opens and is saved as say One Little Indian. Then 2.doc is
saved as Two Little Indians, then 3.doc as Three Little Indians. For
some reason One Little Indian.doc opens with the SaveAs One Little
Indian dialog displayed. Any ideas why?

The Dir function is a little buggy for that. I think that as soon as you
start opening files, Windows moves them to the bottom of the directory and
they are processed twice, or such silly reason. You can either have a count
of file before you start and stop the While when the count has run down, or
use doc properties to signify that a file has already been processed.

I think there are other functions of the FileSystem you can use that are
better than Dir.... but sorry, I don't remember off hand right now and I
don't feel like digging in Google...

3) The original 1.doc 2.doc and 3.doc files remain in the directory. Can
these be deleted as part of the VBA code?

With my first version, this is taken care of. Or, use Kill as in the second
one...

Chers!
--
Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org

 

[Greg Maxey]

JGM,

Thanks. I will have a look at your suggestions and see if I can get it all
to work later today.

 

[Greg]

JGM

I decided to go with your first suggestion and use the counter to
prevent processing the first file twice. The KILL method was
potentially destructive because if you ran the macro a second time it
resulted in all of the files being deleted. My code now.

Option Explicit
Public Sub BatchReNameFiles()

Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim NewName As String
Dim OldName As String
Dim oRng As Range
Dim i As Integer
Dim j As Integer

'Specify folder where files are located
PathToUse = "C:\Batch Folder\"
'Count files in folder
OldName = Dir$(PathToUse & "*.doc")
While OldName <> ""
i = i + 1
OldName = Dir$()
Wend
'Rename files
j = 0
myFile = Dir$(PathToUse & "*.doc")
Do While myFile <> "" And j < i
j = j + 1
Set myDoc = Documents.Open(FileName:=PathToUse & myFile,
Visible:=False)
With myDoc
OldName = .FullName
Set oRng = .Words(1)
oRng.End = .Words(min(9, .Words.Count - 1)).End
NewName = Trim(oRng.Text) & ".doc"
NewName = Replace(NewName, "\", "")
NewName = Replace(NewName, ":", "")
NewName = Replace(NewName, """", "")
NewName = Replace(NewName, vbCr, "")
NewName = Replace(NewName, vbTab, "")
.Close SaveChanges:=wdSaveChanges
End With
Name OldName As PathToUse & NewName
myFile = Dir$()
Loop

End Sub
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function

Thanks Jay, Doug. JGM for your code snippets and assistance.

 

[David Sisson]

Whenever I deal with DIR in reading multiple files, I always pull
everything into a array and work from there. At least I know I have
built a directory list based on search criteria that DOS isn't going to
update.

My $0.02.

David

 

[Greg]

David,

VBA is like Russian to me. I can repeat the words I know and sometimes
I can arrange those words in a sequence to express an idea. Still I
don't speak the language. Could you provide an example of how you:

Pull everything into an array and work from there.

Thanks.

 

[David Sisson]

Something like this:

http://word.mvps.org/faqs/macrosvba/ReadFilesIntoArray.htm

Once you have your array populated, you now have a KNOWN list of files
matching the search criteria and as you iterate through the list, you
know it not going to change.

Search for 'directory array' and you'll find yet another test in the
dir$ loop using vbDirectory for weed out subdirectories.

Again, just a different approach.

David

 

[Greg]

Ok, I suppose I should have known about that MVP FAQ. Thanks. I will
have a look at it.

 

[Greg Maxey]

David,

Is something like the method you were discussing:

Sub BacthFileRenamer()
Dim MyFile As String
Dim PathToUse As String
Dim Counter As Long
Dim myDoc As Document
Dim NewName As String
Dim OldName As String
Dim oRng As Range

'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000) '1000 is arbitrary

'Specify folder containing files
PathToUse = "C:\Batch Folder\"
'Loop through all the files of *.doc in the directory by using Dir$
function
MyFile = Dir$(PathToUse & "*.doc")
'For each file found add to the array
Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
'Get the next file name
MyFile = Dir$
Counter = Counter + 1
Loop

'Reset the size of the array without losing its values by using Redim
Preserve
ReDim Preserve DirectoryListArray(Counter - 1)
Application.ScreenUpdating = False
For Counter = 0 To UBound(DirectoryListArray)
Set myDoc = Documents.Open(FileName:=PathToUse &
DirectoryListArray(Counter), _
Visible:=False)
With myDoc
OldName = .FullName
Set oRng = .Words(1)
oRng.End = .Words(min(9, .Words.Count - 1)).End
NewName = Trim(oRng.Text) & ".doc"
NewName = Replace(NewName, "\", "")
NewName = Replace(NewName, ":", "")
NewName = Replace(NewName, """", "")
NewName = Replace(NewName, vbCr, "")
NewName = Replace(NewName, vbTab, "")
.Close SaveChanges:=wdSaveChanges
End With
Name OldName As PathToUse & NewName
Next Counter
Application.ScreenUpdating = True
End Sub
Private Function min(a As Long, b As Long)
min = -((a < b) * a + (a >= b) * b)
End Function

This bit here:

Do While MyFile <> ""
DirectoryListArray(Counter) = MyFile
'Get the next file name
MyFile = Dir$
Counter = Counter + 1
Loop

Can someone explain (again) the significance of the dollar sign. Why don't
I have to repeat the whole line?
Dir$(PathToUse & "*.doc")