Excel VBA Word mailmerge - объект Word закрывается не сразу - PullRequest
Новая
       19

Excel VBA Word mailmerge - объект Word закрывается не сразу

0 голосов
/ 23 октября 2018

У меня есть проект Excel VBA, который выполняет почтовое слияние "Word".Я считаю, что правильно открываю и закрываю документ и приложение Word, но процесс «winword» остается открытым в течение хороших 45 секунд после завершения выполнения моего кода.

В результате Excel продолжает вести себя так, как онвыполняет «Sub» до тех пор, пока процесс «winword» окончательно не исчезнет.Затем Excel выпускается, и я могу взаимодействовать с ним (в данном случае пользовательской формой).

Я не верю, что у меня было такое поведение до последнего выпуска Office 365.

Здеськод, который я использую для вызова слова и т. д .: 

'Start a new document in Word
                Set oApp = CreateObject("Word.Application")
                Set oDoc = oApp.Documents.Add
                Set oRange = oDoc.Range

                oDoc.MailMerge.MainDocumentType = wdCatalog
                oDoc.PageSetup.Orientation = wdOrientLandscape
                oDoc.MailMerge.OpenDataSource Name:=FullFilePath, LinkToSource:=True, _
                SQLStatement:="SELECT * FROM `namedRangeDynamic`"

                With oDoc.MailMerge

                    Set HdrRange = oDoc.Sections.Item(1).Headers(wdHeaderFooterPrimary).Range
                    oDoc.Tables.Add Range:=HdrRange, NumRows:=1, NumColumns:=4

                    Set oTable = HdrRange.Tables(1)

                        With oTable
                            .Borders.Enable = True
                            .Columns(1).SetWidth ColumnWidth:=oApp.CentimetersToPoints(8), RulerStyle:=wdAdjustFirstColumn
                            .Columns(2).SetWidth ColumnWidth:=oApp.CentimetersToPoints(4.5), RulerStyle:=wdAdjustFirstColumn
                            .Columns(3).SetWidth ColumnWidth:=oApp.CentimetersToPoints(3.5), RulerStyle:=wdAdjustFirstColumn
                            .Columns(4).SetWidth ColumnWidth:=oApp.CentimetersToPoints(6.75), RulerStyle:=wdAdjustFirstColumn
                            .Rows(1).Shading.BackgroundPatternColor = -570408705
                            .Cell(1, 1).Range.Text = "Account Name"
                            .Cell(1, 2).Range.Text = "Last Name"
                            .Cell(1, 3).Range.Text = "First Name"
                            .Cell(1, 4).Range.Text = "Organization"
                        End With

                oDoc.Tables.Add oRange, 1, 4

                Set oTable = oRange.Tables(1)

                    With oTable
                        .Borders.Enable = True
                        .Columns(1).SetWidth ColumnWidth:=oApp.CentimetersToPoints(8), RulerStyle:=wdAdjustFirstColumn
                        .Columns(2).SetWidth ColumnWidth:=oApp.CentimetersToPoints(4.5), RulerStyle:=wdAdjustFirstColumn
                        .Columns(3).SetWidth ColumnWidth:=oApp.CentimetersToPoints(3.5), RulerStyle:=wdAdjustFirstColumn
                        .Columns(4).SetWidth ColumnWidth:=oApp.CentimetersToPoints(6.75), RulerStyle:=wdAdjustFirstColumn
                    End With

                    With oTable
                        .Cell(1, 1).Range.Font.Size = 8
                        .Cell(1, 1).Range.Font.Name = "Arial"
                        .Cell(1, 1).Shading.BackgroundPatternColor = -570359809
                        .Cell(1, 2).Range.Font.Size = 8
                        .Cell(1, 2).Range.Font.Name = "Arial"
                        .Cell(1, 3).Range.Font.Size = 8
                        .Cell(1, 3).Range.Font.Name = "Arial"
                        .Cell(1, 4).Range.Font.Size = 8
                        .Cell(1, 4).Range.Font.Name = "Arial"
                    End With

                    With .Fields
                        .Add oApp.Selection.Range, "Account_Name"
                        oApp.Selection.MoveRight
                        .Add oApp.Selection.Range, "Last_Name"
                        oApp.Selection.MoveRight
                        .Add oApp.Selection.Range, "First_Name"
                        oApp.Selection.MoveRight
                        .Add oApp.Selection.Range, "Company"
                    End With


                End With

                oDoc.MailMerge.Destination = wdSendToNewDocument
                oDoc.MailMerge.Execute


           If cb2_selected = "PDF" Then

                oApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
                SaveAs_FilepathA & "\" & lb2_array_acctName & ".pdf", ExportFormat:=wdExportFormatPDF, _
                OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
                wdExportAllDocument, FROM:=1, To:=1, Item:=wdExportDocumentContent, _
                IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
                wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
                True, UseISO19005_1:=False

            Else

                oApp.ActiveDocument.SaveAs2 Filename:=SaveAs_FilepathA & "\" & lb2_array_acctName & ".docx", FileFormat:= _
                wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
                :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
                :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
                SaveAsAOCELetter:=False, CompatibilityMode:=15

            End If


'Close Word
                oDoc.Close False
                oApp.Visible = False
                oApp.ActiveDocument.Close SaveChanges:=False

                Set oDoc = Nothing

    'Prevent save to Normal template
                    oApp.NormalTemplate.Saved = True
                    oApp.Quit

                Set oApp = Nothing

Спасибо.

...