使用郵件合拼並分存文件資料

前提：先製作完成Word和資料來源的關聯

Sub ProduceDoc()

'Dim stMedd As String
'Dim obMapp As Variant
'stMedd = "請選擇分割後申請表目錄：" '選擇目錄
'Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
'If Not obMapp Is Nothing Then
' linkstr = obMapp.self.Path + "\"
'Else
' Exit Sub
'End If
Dim fso As Object
Dim strSrcName As String, strNewName As String
Set fso = CreateObject("Scripting.FileSystemObject")
strSrcName = ActiveDocument.FullName

'MsgBox fso.GetParentFolderName(strSrcName)
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord
For i = 1 To ActiveDocument.MailMerge.DataSource.RecordCount
strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
fso.GetBaseName(strSrcName) & "_" & i & "." & fso.GetExtensionName(strSrcName))
DoWork (strNewName)
Next i
MsgBox "匯出" + CStr((ActiveDocument.MailMerge.DataSource.RecordCount)) + " 筆資料，結束！"
End Sub
Sub DoWork(filePath As String)
Dim DokName As String

With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
.LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
DokName = .DataFields("FieldName").Value 'Change "FieldName" to your MailMerge field name
End With

' Merge the active record
.Execute Pause:=False
End With

ActiveDocument.Range(0, 0).Select
Selection.PageSetup.SectionStart = wdSectionContinuous

Selection.WholeStory
Selection.Fields.Update '更新照片欄位資料

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

With ActiveDocument.Content.Find 'Selection.Find
.Text = "<br />" ‘取代<br />為斷行
.Replacement.Text = "^p"
.Forward = True
. Wrap = wdFindContinue  ‘不跳出取代後結果
'.Wrap = wdFindAsk have message show
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.CorrectHangulEndings = False
.HanjaPhoneticHangul = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
.Execute Replace:=wdReplaceAll
End With

With ActiveDocument.Content.Find 'Selection.Find
.Text = "^b" ’取代節號為空白
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
.Execute Replace:=wdReplaceAll
End With

‘頁尾資料

  Selection.Sections(1).Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = DokName 
  Selection.Sections(1).Footers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
 


' Save the resulting document.
ActiveDocument.SaveAs2 FileName:=filePath, FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=14

' Close the resulting document
ActiveWindow.Close

' Now, back in the template document, advance to next record
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
End Sub