Macro to Save Multiple Word Documents with Different File Names

[waftycranker]

Hi,

I have to process some 5,000 documents, and need to change their
filename at the same time.

All of the documents have a name in the header in the format:
Firstname Middlename (where it applies) Surname

I need to save the documents as:
Surname, Firstname Middlename.doc

I know how to change the directory they're saved to, and I've managed
to set up the macro to run on all files in a given folder. This is the
only thing that's
stopping me from being able to run the macro.

I don't know what terms to actually search for to be able to find help
on this, so I'm trying here.

I've tried to create a Function that will let me create the filename,
and then use that as the Save As option, but I can't get it to work, as
I can't reference the Function in the SaveAs Filename:=" " It will
only save as what I put in the " "... I've tried using brackets, and
nothing, but no luck.

Any help would be greatly appreciated, even if it's just to tell me
what terms I need to search for on the web, or a website that you think
could help.

Many thanks,

Wafty

 

[Dave Lett]

Can you post the Function that should generate the file name?

Dave

 

[Dave Lett]

The following simple test demonstrates that you can use a function in the
filename parameter:

Public Sub Newsgroup()
ActiveDocument.SaveAs FileName:=fSaveAsName
End Sub

Public Function fSaveAsName() As String
fSaveAsName = ActiveDocument.FullName
End Function

HTH,
Dave

 

[Doug Robbins - Word MVP]

Does your function return a string that would be the filename that you want?

If so, show us what it is and how you are trying to incorporate it into the
SaveAs command and we may be able to help.

--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Wafty Cranker]

I've copied the code that I've managed to write, but I'm not sure that
the function will work, and the SaveAs command doesn't like it.

Public Function fMakeTitle(LastName As String, Firstname As String) As
String
'
' A function to try and create the filename from the header text.
'
Dim fMakeTitle As String
Dim strLastName As String, strFirstName As String

ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HomeKey Unit:=wdPara
Selection.EndKey Unit:=wdLine
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
Selection.Copy
Set strLastName$ = PasteAndFormat(wdPasteNormal)

Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Copy
Set strFirstName$ = PasteAndFormat(wdPasteNormal)

Set fMakeTitle = strLastName & ", " & strFirstName & ".doc"


End Function

Public Sub SaveAsMakeTitle()

ActiveDocument.SaveAs FileName:=fMakeTitle

End Sub

To be honest, the Function seems very clunky to me, but I don't know
how I could make it more relevant to the changing header text.

Any help greatly appreciated.

Thanks.
Wafty

 

[Wafty Cranker]

I've finally managed to get this working.

Thanks for all the help.

The code I've used is:

Borrowed macro from http://www.necco.ca/dv/word_macros.htm

Sub ProcessFiles()
' Steven Marzuola
' Macro to run macros in all files inside a folder
'
myDirectory = "C:\Docs\"
ChangeFileOpenDirectory myDirectory

Dim CurrFile As String
CurrFile = Dir(myDirectory & "\*.doc")

Do While CurrFile <> ""

' Insert code to open a file. This will probably work:
Documents.Open FileName:=CurrFile

' Then call the macros
' [MISSING LINE]
Application.Run "DelInfo"

' Close the file if desired.
' [MISSING LINE]

ActiveWindow.Close SaveChanges:=SaveChanges

' Call the Dir command again to get the next filename.
CurrFile = Dir
Loop
End Sub

---------------------------------------------------------------------------------------------

Sub DelInfo()
'
' DelInfo Macro
' Macro recorded 5/30/2006 by Me
'
Selection.HomeKey Unit:=wdStory
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Font.Size = 24
Selection.Font.Bold = wdToggle
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
If Selection.Font.Underline = wdUnderlineNone Then
Selection.Font.Underline = wdUnderlineSingle
Else
Selection.Font.Underline = wdUnderlineNone
End If
Selection.TypeText Text:="My Random Title"
Selection.TypeParagraph
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or
ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Call WriteProp(sPropName:="Company", sValue:="")
Call WriteProp(sPropName:="Author", sValue:="")

Dim fMakeTitle As String
Dim strLastName As String, strFirstName As String

ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.EndKey Unit:=wdLine
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
Selection.Copy
strLastName = Selection.Text

Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Copy
strFirstName = Selection.Text

fMakeTitle = strLastName & ", " & strFirstName & ".doc"

ActiveDocument.SaveAs FileName:=fMakeTitle, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False

End Sub

Thanks again.

Wafty