zebradoby
05-21-2008, 03:50 PM
I have this code to divide the huge word file (50 pages) into 50 files of 1 pages each. I want to save the file on a pre defined folder with a pre defined name. Can anyone please help?
To use code:
Open word.
Copy code
Click Run
Select a file with at least 4 pages (word file)
I want to save the file as "Loan Number.date.cor.doc" . The Loan Number is part of document on each page.
Let me know if anyone can help. Please see code below. If you want to help by writing an easier code please disregard my code.
'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave
Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")
'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name
FileToOpen = wrdDoc.Name
'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"
Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var
Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
Set thisdoc = Activedocument
Dim S As Section
Dim Loan As Range
Dim TempNo As Long
Dim FileSuffix As String
Dim FilePrefix As String
FilePrefix = "C:\"
For Each S In thisdoc.Sections
Set Loan = S.Range.Duplicate
If Loan.Find.Execute(FindText:="Mortgage Loan Number:") Then
Loan.MoveWhile " " & vbTab & vbTab & vbTab & vbTab
Loan.MoveEndUntil Chr(13)
FileSuffix = Loan.Text
Else
TempNo = TempNo + 1
FileSuffix = "Temp" & TempNo
End If
S.Range.Copy
With Documents.Add
.Range.PasteAndFormat (wdFormatOriginalFormatting)
.Sections(1).Range.Characters.Last.Delete
If Dir(FilePrefix & FileSuffix & ".doc") <> "" Then
TempNo = TempNo + 1
FileSuffix = "Dup" & TempNo & " " & FileSuffix
End If
.SaveAs FilePrefix & FileSuffix & "." & Format(Date, "mmddyyyy") & "." & "cor" & ".doc", wdFormatDocument
.Close
End With
Next
Activedocument.Close savechanges:=wdDoNotSaveChanges
'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."
End If
End Sub
''' Function: FileOpenCustom
Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.
If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function
To use code:
Open word.
Copy code
Click Run
Select a file with at least 4 pages (word file)
I want to save the file as "Loan Number.date.cor.doc" . The Loan Number is part of document on each page.
Let me know if anyone can help. Please see code below. If you want to help by writing an easier code please disregard my code.
'Macro recorded/Edited 10/07/07
Sub FileOpenTest()
Dim FileToOpen
Dim FileToSave
Dim szFileName As String
Dim wrdDoc As Document
'''This is just to demonstrate the below library function.
szFileName = FileOpenCustom1("", "*.Doc")
'''In reality it would be more productive to pass a document object back.
If szFileName <> "" Then
Set wrdDoc = Word.Documents(szFileName)
' disabled
' MsgBox wrdDoc.Path + Chr$(13) + wrdDoc.Name
FileToOpen = wrdDoc.Name
'Modified oct 6 2007
'Parse out .txt and replace with .doc
FileToSave = Left(wrdDoc.Name, Len(wrdDoc.Name) - 4) & ".doc"
Dim varDocOne As Variant
Dim j As Long
Dim r As Range
Dim thisdoc As Document
Dim Thatdoc As Document
Dim var
Documents.Open FileName:=FileToOpen, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto
Set thisdoc = Activedocument
Dim S As Section
Dim Loan As Range
Dim TempNo As Long
Dim FileSuffix As String
Dim FilePrefix As String
FilePrefix = "C:\"
For Each S In thisdoc.Sections
Set Loan = S.Range.Duplicate
If Loan.Find.Execute(FindText:="Mortgage Loan Number:") Then
Loan.MoveWhile " " & vbTab & vbTab & vbTab & vbTab
Loan.MoveEndUntil Chr(13)
FileSuffix = Loan.Text
Else
TempNo = TempNo + 1
FileSuffix = "Temp" & TempNo
End If
S.Range.Copy
With Documents.Add
.Range.PasteAndFormat (wdFormatOriginalFormatting)
.Sections(1).Range.Characters.Last.Delete
If Dir(FilePrefix & FileSuffix & ".doc") <> "" Then
TempNo = TempNo + 1
FileSuffix = "Dup" & TempNo & " " & FileSuffix
End If
.SaveAs FilePrefix & FileSuffix & "." & Format(Date, "mmddyyyy") & "." & "cor" & ".doc", wdFormatDocument
.Close
End With
Next
Activedocument.Close savechanges:=wdDoNotSaveChanges
'Message displayed on completing the macro
MsgBox "Files have been saved at the specified location."
End If
End Sub
''' Function: FileOpenCustom
Function FileOpenCustom1(pszInitDir As String, pszFilter As String) As String
Dim dlgFileOpen As Word.Dialog
Dim szCurDir As String
Dim szdlgFullName As String
Dim wrdDoc As Word.Document
'''Store the current document path
szCurDir = Application.Options.DefaultFilePath(wdDocumentsPath)
'''If pszInitDir is empty use the default path.
If pszInitDir <> "" Then
ChDir pszInitDir
Else
pszInitDir = szCurDir
End If
'''Initailize and reference the dialog object.
Set dlgFileOpen = Word.Dialogs(wdDialogFileOpen)
With dlgFileOpen
'''Update the dialog object.
.Update
'''Set the filter
.Name = pszFilter
'''Display and execute the dialog.
If .Show() <> False Then
'''If the user didn't cancel...
'''The active document is the one just opened.
Set wrdDoc = Activedocument
'''Cheat and use the document object to do the parsing.
'''Return the name of the document.
FileOpenCustom1 = wrdDoc.Name
End If
End With
'''Restore the default path setting.
With Application.Options
If .DefaultFilePath(wdDocumentsPath) <> szCurDir Then
.DefaultFilePath(wdDocumentsPath) = szCurDir
End If
End With
End Function