Excel宏创建的邮件合并文档没有被Excel发布？

Question

我的用户表单中有一个带有一系列切换按钮的用户表单，每个按钮代表一个不同的报告选项。当用户通过按下该报告的相关按钮选择一个（或多个）报告时，该报告查询被放入一个提示中，代码将循环处理每个提示。 在循环中，针对该特定报告执行 Word 邮件合并。执行邮件合并，创建文档并随后保存。那些新创建的 Word 文档保持打开状态。用户的偏好是通过单击与用户表单中的特定报告相对应的先前按下的切换按钮来关闭那些 word 文档。这似乎工作正常。

现在，用户可以在创建这些文档后（以及在关闭之前）访问这些文档，并对其进行编辑和打印。它们打印良好，但无法保存任何更改。用户可以单击打开的 Word 文档菜单中的保存图标，直到他们的鼠标电池耗尽并且没有任何保存。但是，如果您返回 Excel，单击工作表，然后返回 Word 文档，则可以保存它。 （几乎就像这样做打破了两个文档之间的束缚）

如果用户从关闭状态的保存位置（即从目录）访问这些 Word 文档，它们会打开并且可以编辑，但同样不能保存。只要 Excel 对创建文档的应用程序开放。编辑：情况并非如此。即使 EXCEL 关闭，这些以前创建的邮件合并文档，虽然可编辑可编辑。由于文件权限错误，无法重新保存。

我发现，如果我的 Excel 应用程序关闭，这些文件不再出现由于文件权限错误而导致保存的困难。看起来，一旦 Excel 启动并生成了这些报告，它就会对它们进行一些“锁定”。这些文档，只要用来生成它们的 Excel 应用程序是打开的，它们似乎并没有完全从 Excel 生成代码中释放出来。

Sub merge2(ByVal i As Long, ByVal rpt_od As String, objWord As Object, ByVal dest As Long)

    Dim oDoc As Object, oDoc2 As Object
    Dim StrSQL As String, fName As String, StrSrc As String, strFilename As String, myPath As String
    Dim qfile As String, st_srchfn As String, wb_qfile2 As Workbook, itype As String, isubresp As String
    'Dim wb_qfile2 As Workbook
    Dim HdFt As Variant
    Dim wdSendToNewDocument

    Const wdSendtToNewDocument = 0
    Const wdSendToPrinter = 1
    Const wdFormLetters = 0
    Const wdDirectory = 3
    Const wdMergeSubTypeAccess = 1
    Const wdOpenFormatAuto = 0

    work_fn = ws_vh.Range("N2")
    Set wb_nwb = Workbooks(work_fn)

    'create workorders folder
    myPath = "u:\fff\ffff\ffffffffffff\fffff\fffff\WORKORDERS\" & format(ws_vh.Range("B17"), "ddd dd-mmm-yy")
    If Dir(myPath, vbDirectory) = "" Then 'if not already created ...
        MkDir myPath
    End If

    'close data file
    st_srchfn = "u:\u:\fff\ffff\ffffffffffff\fffff\fffff\DATA\" & ws_vh.Range("N2")
    If wb_nwb Is Nothing Then
        MsgBox wb_nwb & " is NOT open."
    Else
        wb_nwb.Close True 'saves data workbook after TYPE was updated for GS
        With ws_base
            .Range("B24:D24").Value = ws_vh.Range("A57:C57").Value
        End With
    End If

    itype = Right(ws_th.Range("A" & i), 2)
    isubresp = Left(ws_th.Range("A" & i), 3)

    If itype = "DR" Then
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\DR15NG.docx"
    ElseIf itype = "DT" Then
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\DT15NG.docx"
    ElseIf itype = "FR" Then
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\FR15NG.docx"
    ElseIf itype = "FT" Then
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\FT15NG.docx"
    ElseIf itype = "CR" Then
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\CR15NG.docx"
    ElseIf itype = "CT" Then
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\CT15NG.docx"
    ElseIf itype = "GS" Then
        If isubresp = "HPE" Or isubresp = "HPL" Then
            fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\GS15NG_GSH.docx" 'Passive : Hillside
        Else
            fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\GS15NG_GS.docx" 'Passive : Wloo Park
        End If
    Else
        fName = "u:\fff\ffff\ffffffffffff\fffff\fffff\REPORTS\NG\GS15NG_GM.docx"
    End If

    StrSrc = "u:\fff\ffff\ffffffffffff\fffff\fffff\DATA\" & ws_vh.Range("N2")

    StrSQL = "SELECT * FROM [DATA$] WHERE [TYPE]='" & itype & "' AND [SIG_CREW]='" & isubresp & "' " & _
        "ORDER BY [STARTS] ASC, [COMPLEX] ASC, [UNIT] ASC"

    Set objWord = CreateObject("Word.Application")
    With objWord
        .DisplayAlerts = False
        .Visible = True
        Set oDoc = .Documents.Open(Filename:=fName, ConfirmConversions:=False, _
            ReadOnly:=True, AddToRecentFiles:=False, Visible:=True)
        With oDoc
            With .MailMerge
                .MainDocumentType = wdFormLetters
                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                .OpenDataSource Name:=StrSrc, AddToRecentFiles:=False, LinkToSource:=False, ConfirmConversions:=False, _
                    ReadOnly:=True, format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "User ID=Admin;Data Source=" & StrSrc & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";", _
                    SQLStatement:=StrSQL, SQLStatement1:="", SubType:=wdMergeSubTypeAccess
                .Execute Pause:=False
            End With
            .Close False
        End With
        .DisplayAlerts = True

        'page break routine only for sports reports
        If (Left(itype, 1) <> "G") And (itype <> "DT") Then   'exclude GS reports
            With .activedocument
                If .Sections.count > 1 Then
                    For Each HdFt In .Sections(.Sections.count).Headers
                        If HdFt.Exists Then
                            HdFt.Range.FormattedText = .Sections(1).Headers(HdFt.index).Range.FormattedText
                            HdFt.Range.Characters.Last.Delete
                        End If
                    Next
                    For Each HdFt In .Sections(.Sections.count).Footers
                        If HdFt.Exists Then
                            HdFt.Range.FormattedText = .Sections(1).Footers(HdFt.index).Range.FormattedText
                            HdFt.Range.Characters.Last.Delete
                        End If
                    Next
                End If
                Do While .Sections.count > 1
                    .Sections(1).Range.Characters.Last.Delete
                    DoEvents
                Loop
                .Range.Characters.Last.Delete
            End With
        End If

    End With

    Set oDoc2 = objWord.activedocument

    'save newly created document
    With oDoc2
        myPath = "u:\fff\ffff\ffffffffffff\fffff\fffff\WORKORDERS\" & format(ws_vh.Range("B17"), "ddd dd-mmm-yy")
        .SaveAs myPath & "\" & rpt_od & ".docx"
        If dest = 2 Then
            .PrintOut
        End If
        '.Close
    End With


    Set oDoc = Nothing: Set oDoc2 = Nothing ': Set objWord = Nothing

End Sub

Answer 1

问题是您正在创建一个新的 Word 会话来生成文档，但您从未关闭它们或退出新的 Word 会话，从而使其在后台处于孤立状态，而文档仍处于打开状态。