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

前提：先製作完成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