Private Sub Document_Open()
DocSave "TestSave"
End Sub
Sub DocSave(DocName)
Dim Rec As Integer
Dim ToBeSaved As String, MergeFileName As String, JobNo As String, Direct As String
Dim Project As String, SaveName As String, SaveAsName As String
Dim Length As Integer
Dim Message As String, Title As String, Default As String, MyValue As String
Dim DataF As Variant, DRecord As String
Const SaveRoot = "C:\Atest\"
On Error Resume Next
CommandBars("Merge File").Visible = False
Message = "Enter Sub-Folder/Filename for saving" & Chr(13) & _
"NB - New sub-folders will not be created" & Chr(13) & Chr(13) & _
"Press Cancel to proceed without saving."
Title = "Document File Name"
SaveName = InputBox(Message, Title, DocName)
MergeFileName = ActiveDocument.Name
If SaveName = "" Then
ToBeSaved = "No"
GoTo MailMergeLine
End If
On Error Resume Next
CommandBars("MailMerge").Visible = False
On Error Resume Next
CommandBars("Web").Visible = False
Rec = 0
For Each DataF In _
Documents(MergeFileName).MailMerge.DataSource.DataFields
Rec = Rec + 1
DRecord = DataF.Value
If Rec = 1 Then JobNo = DRecord
If Rec = 2 Then Project = DRecord
If Rec = 3 Then GoTo MailMergeLine
Next DataF
MailMergeLine:
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.Execute
End With
If ToBeSaved = "No" Then GoTo LastLine
Direct = SaveRoot & JobNo & " " & Project & "\"
Length = Len(SaveName)
If Right(SaveName, 4) = ".doc" Then
SaveName = Left(SaveName, Length - 4)
End If
SaveAsName = SaveName & ".doc"
ChangeFileOpenDirectory Direct
With Application.FileSearch
.NewSearch
.LookIn = Direct
.SearchSubFolders = False
.FileName = SaveName & "*"
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
SaveAsName = SaveName & "-" & .FoundFiles.Count & ".doc"
End If
End With
ActiveDocument.SaveAs FileName:=SaveAsName
MsgBox ActiveDocument.Path & Application.PathSeparator & ActiveDocument.Name
LastLine:
Windows(MergeFileName).Close savechanges:=False
End Sub
|