Outlook VBA Not Closing Word Process

Question

I have an some outlook VBA scripts that loop through all selected emails and save them as a PDF file, then move them to another folder in my outlook. It works most of the time, sometimes however it will hang and when I look at my processes, WINWORD.EXE*32 is open many many times. I have to quit each of them before Outlook will resume working. Outlook will also crash everyone once in awhile when I attempt to run this script. I've tried using late binding, but that's not helping either. Also, I have the same code (without the for each loop on the selection) in 'Rule' form for another set of emails and it has the same problem. Word is opening multiple times in the background and will not quit. Here is my code:

Option Explicit
Dim MyTicketNumber As String
    
Sub ProcessResponse()
    Response_SaveAsPDFwAtt
    MoveToResponses
End Sub

Sub Response_SaveAsPDFwAtt()

Dim fso As FileSystemObject
Dim blnOverwrite As Boolean
Dim sendEmailAddr As String
Dim senderName As String
Dim rcvdTime As String
Dim pubTime As String
Dim looper As Integer
Dim plooper As Integer
Dim oMail As Outlook.MailItem
Dim Obj As Object
Dim MySelection As Selection
Dim bpath As String
Dim EmailSubject As String
Dim saveName As String
Dim PDFSave As String



Set MySelection = Application.ActiveExplorer.Selection

For Each Obj In MySelection

    Set oMail = Obj

    ' ### Get username portion of sender email address ###
        sendEmailAddr = oMail.SenderEmailAddress
        senderName = Left(sendEmailAddr, InStr(sendEmailAddr, "@") - 1)
        rcvdTime = "_Rcvd" & Format(oMail.ReceivedTime, "yymmddhhnnss")
        pubTime = "_Pub" & Format(Now(), "yymmddhhnnss")
        MyTicketNumber = GetTicketNumber(oMail)



    ' ### USER OPTIONS ###
        blnOverwrite = False ' False = don't overwrite, True = do overwrite

    ' ### Path to save directory ###
        bpath = "L:\OpenLocates\Current\Complete\" & MyTicketNumber & "\"

    ' ### Create Directory if it doesnt exist ###
        If Dir(bpath, vbDirectory) = vbNullString Then
            MkDir bpath
        End If

    ' ### Get Email subject & set name to be saved as ###
        EmailSubject = CleanFileName(oMail.Subject)
        saveName = 2 & MyTicketNumber & rcvdTime & pubTime & ".mht"
        Set fso = CreateObject("Scripting.FileSystemObject")

    ' ### Increment filename if it already exists ###
        If blnOverwrite = False Then
            looper = 0
            Do While fso.FileExists(bpath & saveName)
                looper = looper + 1
                saveName = 2 & MyTicketNumber & rcvdTime & pubTime & "_" & Format(plooper, "0000") & ".mht"
                Loop
        Else
        End If

    ' ### Save .mht file to create pdf from Word ###
        oMail.SaveAs bpath & saveName, olMHTML
        PDFSave = bpath & 2 & MyTicketNumber & rcvdTime & pubTime & ".pdf"

        If fso.FileExists(PDFSave) Then
            plooper = 0
            Do While fso.FileExists(PDFSave)
            plooper = plooper + 1
            PDFSave = bpath & 2 & MyTicketNumber & rcvdTime & pubTime & "_" & Format(plooper, "0000") & ".pdf"
            Loop
        Else
        End If


    ' ### Open Word to convert .mht file to PDF ###
        Dim wordApp As Object
        Dim wordDoc As Object
        Dim wordOpen As Boolean
        On Error Resume Next
        Set wordApp = GetObject(, "word.application")
        On Error GoTo 0
        If wordApp Is Nothing Then
            Set wordApp = CreateObject("Word.Application")
            wordOpen = True
        End If
            

    ' ### Open .mht file we just saved and export as PDF ###
        Set wordDoc = wordApp.Documents.Open(FileName:=bpath & saveName, Visible:=True)
        wordApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        PDFSave, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
        item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False

        wordDoc.Close
        Set wordDoc = Nothing
        If wordOpen Then wordApp.Quit
        Set wordApp = Nothing
    ' ### Delete .mht file ###
        Kill bpath & saveName

    ' ### save attachments ###
        If oMail.Attachments.Count > 0 Then
            Dim atmt As Attachment
            Dim atmtName As String
            Dim atmtSave As String
            For Each atmt In oMail.Attachments
                atmtName = CleanFileName(atmt.FileName)
                atmtSave = bpath & 2 & MyTicketNumber & rcvdTime & pubTime & "_" & atmtName
                atmt.SaveAsFile atmtSave
            Next
        End If
Next Obj

MsgBox "Process Complete.", vbInformation, "Success"
Exit_Handler:
'if i use worddoc.close and wordapp.quit with the 
'set = nothing lines here, it gives me an error saying object not found

Set oMail = Nothing
Set Obj = Nothing
Set MySelection = Nothing
Set fso = Nothing
End Sub

I thought it was possibly the for each loop, but the rule version of this still leaves winword.exe*32 open. I think I must be overlooking something.
When I run this script on a co-workers computer, the word process appears to be closing. I'm using Windows 7 she's using Windows 10 but we are both using Outlook 2016.

AmandaKay10 AmandaKay10 · Accepted Answer · 2018-06-18T20:40:38

I reverted Office back to build 1802 from build 1806, the problem seems to have gone away.

Outlook VBA Not Closing Word Process

1 Answers