VBA代码-Word邮件批量保存-购销合同&收货证明

Sub 购销合同()

'主文档的类型为信函

'合并全部数据记录

'假设主文档已链接好数据源，可以进行正常的邮件合并

Dim myMerge As MailMerge, i As Integer, myname As String

Application.ScreenUpdating = False

If Dir("E:\Contracts\合同及收货证明" & Format(Date, "YYMMDD"), vbDirectory) <> "" Then

       

   Else

      

       MkDir "E:\Contracts\合同及收货证明" & Format(Date, "YYMMDD")

 End If

Set myMerge = ActiveDocument.MailMerge

With myMerge.DataSource

    If .Parent.State = wdMainAndDataSource Then

        .ActiveRecord = wdFirstRecord

        For i = 1 To .RecordCount

            .FirstRecord = i

            .LastRecord = i

            .Parent.Destination = wdSendToNewDocument

            '取得数据源第4个和第2个字段（合并域）的当前数据字符串，用以命名文件，根据需要增减修改

            myname = .DataFields(4).Value & .DataFields(2).Value & "-购销合同"

            .ActiveRecord = wdNextRecord

            .Parent.Execute  '每次合并一个数据记录

            With ActiveDocument

                .Content.Characters.Last.Previous.Delete  '删除分节符

                .SaveAs "E:\Contracts\合同及收货证明" & Format(Date, "YYMMDD") & "\" & myname & ".doc" '假设生成的各文档保存于E盘根目录下

                .Close  '关闭生成的文档（已保存）

            End With

        Next

    End If

End With

Application.ScreenUpdating = True

End Sub

Sub 收货证明()

'主文档的类型为信函

'合并全部数据记录

'假设主文档已链接好数据源，可以进行正常的邮件合并

Dim myMerge As MailMerge, i As Integer, myname As String

Application.ScreenUpdating = False

If Dir("E:\Contracts\合同及收货证明" & Format(Date, "YYMMDD"), vbDirectory) <> "" Then

       

   Else

      

       MkDir "E:\Contracts\合同及收货证明" & Format(Date, "YYMMDD")

 End If

Set myMerge = ActiveDocument.MailMerge

With myMerge.DataSource

    If .Parent.State = wdMainAndDataSource Then

        .ActiveRecord = wdFirstRecord

        For i = 1 To .RecordCount

            .FirstRecord = i

            .LastRecord = i

            .Parent.Destination = wdSendToNewDocument

            '取得数据源第4个和第2个字段（合并域）的当前数据字符串，用以命名文件，根据需要增减修改

            myname = .DataFields(4).Value & .DataFields(2).Value & "-收货证明"

            .ActiveRecord = wdNextRecord

            .Parent.Execute  '每次合并一个数据记录

            With ActiveDocument

                .Content.Characters.Last.Previous.Delete  '删除分节符

                .SaveAs "E:\Contracts\合同及收货证明" & Format(Date, "YYMMDD") & "\" & myname & ".doc" '假设生成的各文档保存于E盘根目录下

                .Close  '关闭生成的文档（已保存）

            End With

        Next

    End If

End With

Application.ScreenUpdating = True

End Sub