DEVHIDE
Login Or Sign up

Outlook email attachments missing randomly by using excel vba

132 Views Asked by At 
your text

Hi, needed your expert advice on the below code. i am having no error and the code is downloading attachments properly but some of the email missed to download attachments (randomly, downloaded if run macro again) and email moves to process folder. please have a look on the code below and advise.

Sub Outlook_Automation()
Excel.Application.ScreenUpdating = False
Excel.Application.DisplayAlerts = False
'Main Procedure
With ActiveSheet
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
ActiveSheet.Range("A" & lastrow + 1).Value = VBA.Now

Set objoutlook = CreateObject("Outlook.Application")
Set outlookNameSpace = objoutlook.GetNamespace("MAPI")
Set olShareName = outlookNameSpace.CreateRecipient("PostRoom@*****.com")
'// Owner's email address
Set MyFolder = outlookNameSpace.GetSharedDefaultFolder(olShareName, olFolderInbox)
Set UnprocessedDestFolder = MyFolder.Folders("Unprocessed")
Set ImageDestFolder = MyFolder.Folders("Image")
Set UnprocessedItems = UnprocessedDestFolder.Items
Set ImageItems = ImageDestFolder.Items
Set processedDestFolder = MyFolder.Folders("Processed")
Set processedItems = processedDestFolder.Items
preeProcessItemCount = processedItems.Count
preUnprocessItemCount = UnprocessedItems.Count
preImageItemCount = ImageItems.Count

Set PreProcessFolder = MyFolder.Folders("Pre-Processing")
Set PreprocessItems = PreProcessFolder.Items
Set PreprocessItems = PreprocessItems.Restrict("[Unread] = true")
preProcessItemCount = PreprocessItems.Count
ActiveSheet.Range("B" & lastrow + 1).Value = preProcessItemCount
savefolder = "S:\*****\RPA\OCR\OCRInputOutlook\"
If PreprocessItems.Count <> 0 Then
For x = PreprocessItems.Count To 1 Step -1
On Error Resume Next
    Set PreprocessMSG = PreprocessItems.Item(x)
        Call Check_File_Extension
            If RequiredBoolFileCheck = True And UnprocessFileCheck = False Then
                Call Convert_And_Save(x)
                Excel.Application.Wait Now + TimeValue("00:00:02")
                PreprocessItems.Item(x).Move processedDestFolder
            Excel.Application.Wait Now + TimeValue("00:00:02")
            ElseIf ImageBoolFileCheck = True Then
                Call Convert_And_Save(x)
                Excel.Application.Wait Now + TimeValue("00:00:02")
                PreprocessItems.Item(x).Move ImageDestFolder
               Excel.Application.Wait Now + TimeValue("00:00:02")
            ElseIf PreprocessMSG.Attachments.Count = 0 Or UnprocessFileCheck = True Then
                 Call Convert_And_Save(x)
                 Excel.Application.Wait Now + TimeValue("00:00:02")
                 PreprocessItems.Item(x).Move UnprocessedDestFolder
            End If
 Excel.Application.Wait Now + TimeValue("00:00:04")
Next x
End If
Set processedItems = processedDestFolder.Items
Set UnprocessedItems = UnprocessedDestFolder.Items
Set ImageItems = ImageDestFolder.Items
ProcessItemCount = processedItems.Count
UnprocessItemCount = UnprocessedItems.Count
ImageItemCount = ImageItems.Count
End Sub

Sub Check_File_Extension()
' Function for checkin extension to define OOS and In scope
 RequiredBoolFileCheck = False
 ImageBoolFileCheck = False
 UnprocessFileCheck = False
    i = 1
    
    For Each objAttachment In PreprocessMSG.Attachments
        filenamepre(i) = objAttachment.FileName
            If LCase(Right(filenamepre(i), 4)) = "docx" Or LCase(Right(filenamepre(i), 4)) = "xlsx" Or LCase(Right(Trim(filenamepre(i)), 3)) = "pdf" Or LCase(Right(filenamepre(i), 3)) = "pdf" Or LCase(Right(filenamepre(i), 3)) = "doc" Or LCase(Trim(Right(filenamepre(i), 3))) = "xls" Or LCase(Right(filenamepre(i), 3)) = "xls" Or UCase(Right(filenamepre(i), 3)) = "CSV" Or LCase(Right(filenamepre(i), 3)) = "odt" Or LCase(Right(filenamepre(i), 3)) = "rtf" Or LCase(Right(filenamepre(i), 4)) = "docm" Then
                        RequiredBoolFileCheck = True
                    ElseIf LCase(Right(filenamepre(i), 3)) = "jpg" Or LCase(Right(filenamepre(i), 3)) = "tif" Or LCase(Right(filenamepre(i), 4)) = "jpeg" Then
                        ImageBoolFileCheck = True
                    Exit For
            Else
                    UnprocessFileCheck = True
            End If
            i = i + 1
    Next objAttachment
    
End Sub

Sub Convert_And_Save(ByVal x As Long)
' Function to change the format and save to define folder N:\*****\RPA\OCR\OCR Input Outlook\
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim pdfName As String
savefolder = "S:\*****\RPA\OCR\OCRInputOutlook\"
    For Each objAttachment In PreprocessMSG.Attachments
        If UCase(Right(objAttachment.FileName, 3)) = "PDF" Or UCase(Right(Trim(objAttachment.FileName), 3)) = "PDF" Or LCase(Right(Trim(objAttachment.FileName), 3)) = "pdf" Or LCase(Right(objAttachment.FileName, 3)) = "pdf" Then
            dateformat = Format(Now, "yyyymmddHmmss")
            objAttachment.SaveAsFile savefolder & dateformat & Replace(objAttachment.FileName, "-", "")
            Excel.Application.Wait Now + TimeValue("00:00:02")
        ElseIf UCase(Right(objAttachment.FileName, 4)) = "DOCX" Or UCase(Right(objAttachment.FileName, 3)) = "DOC" Or UCase(Right(objAttachment.FileName, 3)) = "RTF" Or UCase(Right(objAttachment.FileName, 3)) = "ODT" Or UCase(Right(objAttachment.FileName, 4)) = "DOCM" Then
            dateformat = Format(Now, "yyyymmddHmmss")
            FilePath = "S:\*****\RPA\OCR\Temp Path\" & objAttachment.FileName
            objAttachment.SaveAsFile (FilePath)
            Excel.Application.Wait Now + TimeValue("00:00:02")
            Set wordApp = CreateObject("Word.Application")
            Set wordDoc = wordApp.Documents.Open(FilePath)
            
            pdfName = savefolder & Replace(objAttachment.FileName, "-", "") & dateformat & ".pdf"
            wordDoc.ExportAsFixedFormat OutputFileName:=pdfName, ExportFormat:= _
            wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
            Item:=wdExportDocumentContent, IncludeDocProps:=True
            Excel.Application.Wait Now + TimeValue("00:00:02")
            wordDoc.Close savechanges:=False
            wordApp.Quit
            Set wordApp = Nothing
            
         ElseIf UCase(Right(objAttachment.FileName, 4)) = "XLSX" Or UCase(Right(objAttachment.FileName, 3)) = "XLS" Or UCase(Right(objAttachment.FileName, 3)) = "CSV" Then
            On Error Resume Next
            dateformat = Format(Now, "yyyymmddHmmss")
            FilePath = "S:\*****\RPA\OCR\Temp Path\" & objAttachment.FileName
            objAttachment.SaveAsFile (FilePath)
            Dim wkb As Workbook
            Set wkb = Workbooks.Open(FilePath, editable:=True)
            If Application.ProtectedViewWindows.Count > 0 Then
            Application.ActiveProtectedViewWindow.Edit
            End If
            Dim ws As Worksheet
            Set ws = Nothing
            savefolder = "S:\*****\RPA\OCR\OCRInputOutlook\"
            pdfName = savefolder & Replace(objAttachment.FileName, "-", "") & dateformat & ".pdf"
            Dim cnt As Integer
            cnt = 1
            For Each ws In wkb.Worksheets
            If Not ws.Visible = xlSheetHidden Then
              
                If Not ws.Visible = xlSheetVeryHidden Then
                If Not ws.UsedRange.Address = "$A$1" Then
                    ws.Copy
                    cnt = cnt + 1
                End If
                Set newWb = ActiveWorkbook
                Set newWs = newWb.ActiveSheet
                If cnt = 1 Then
                    newWs.ExportAsFixedFormat Type:=xlTypePDF, FileName:=pdfName, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, OpenAfterPublish:=False
                Else
                    pdfName = savefolder & Replace(objAttachment.FileName, "-", "") & dateformat & "_" & cnt & ".pdf"
                    newWs.ExportAsFixedFormat Type:=xlTypePDF, FileName:=pdfName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                End If
                    newWb.Close savechanges:=False
                Else
                ws.Select
                
          ws.ExportAsFixedFormat Type:=xlTypePDF, FileName:=pdfName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            End If
            End If
            Next ws
            
            wkb.Save
            wkb.Close savechanges:=False
        End If
    Next objAttachment
End Sub

your help is appreciated....

excel vba6
Original Q&A
1

There are 1 best solutions below

2
On

After removing On Error Resume Next, this may aid your debugging.

Option Explicit

Sub Outlook_Automation()

'Excel.Application.ScreenUpdating = False
'Excel.Application.DisplayAlerts = False

'Main Procedure

Dim lastrow As Long
With ActiveSheet
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With

ActiveSheet.Range("A" & lastrow + 1).Value = VBA.Now

Dim objoutlook As Object
Dim OutlookNamespace As Object
Set objoutlook = CreateObject("Outlook.Application")
Set OutlookNamespace = objoutlook.GetNamespace("MAPI")

Set olShareName = OutlookNamespace.CreateRecipient("PostRoom@*****.com")

'// Owner's email address
Dim myFolder As Object
Set myFolder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)

Dim UnprocessedDestFolder As Object
Dim ImageDestFolder As Object
Dim UnprocessedItems As Object
Dim ImageItems As Object
Dim processedDestFolder As Object
Dim processedItems As Object

Set UnprocessedDestFolder = myFolder.Folders("Unprocessed")
Set ImageDestFolder = myFolder.Folders("Image")
Set UnprocessedItems = UnprocessedDestFolder.Items
Set ImageItems = ImageDestFolder.Items
Set processedDestFolder = myFolder.Folders("Processed")
Set processedItems = processedDestFolder.Items

Dim preeProcessItemCount As Long
Dim preUnprocessItemCount As Long
Dim preImageItemCount As Long

preeProcessItemCount = processedItems.Count
preUnprocessItemCount = UnprocessedItems.Count
preImageItemCount = ImageItems.Count

Dim PreProcessFolder As Object
Dim PreprocessItems As Object

Set PreProcessFolder = myFolder.Folders("Pre-Processing")
Set PreprocessItems = PreProcessFolder.Items
Set PreprocessItems = PreprocessItems.Restrict("[Unread] = true")

Dim preProcessItemCount As Long
preProcessItemCount = PreprocessItems.Count
Debug.Print "preProcessItemCount: " & preProcessItemCount
ActiveSheet.Range("B" & lastrow + 1).Value = preProcessItemCount

Dim savefolder As String
savefolder = "S:\*****\RPA\OCR\OCRInputOutlook\"

Dim RequiredBoolFileCheck As Boolean
Dim ImageBoolFileCheck As Boolean
Dim UnprocessFileCheck As Boolean

Dim x As Long
Dim PreprocessMSG As Object

If PreprocessItems.Count <> 0 Then

    For x = PreprocessItems.Count To 1 Step -1
        
        Set PreprocessMSG = PreprocessItems.Item(x)
        
        Call Check_File_Extension(RequiredBoolFileCheck, _
          ImageBoolFileCheck, UnprocessFileCheck, PreprocessMSG)
        
        'Debug.Print "RequiredBoolFileCheck: " & RequiredBoolFileCheck
        'Debug.Print "UnprocessFileCheck...: " & UnprocessFileCheck
        'Debug.Print "RequiredBoolFileCheck: " & RequiredBoolFileCheck
        
        If RequiredBoolFileCheck = True And UnprocessFileCheck = False Then
            Call Convert_And_Save(x, PreprocessMSG)
            'Excel.Application.Wait Now + TimeValue("00:00:02")
            PreprocessItems.Item(x).Move processedDestFolder
            'Excel.Application.Wait Now + TimeValue("00:00:02")
            
        ElseIf ImageBoolFileCheck = True Then
            Call Convert_And_Save(x, PreprocessMSG)
            'Excel.Application.Wait Now + TimeValue("00:00:02")
            PreprocessItems.Item(x).Move ImageDestFolder
            'Excel.Application.Wait Now + TimeValue("00:00:02")
                
        ElseIf PreprocessMSG.Attachments.Count = 0 Or _
          UnprocessFileCheck = True Then
            Call Convert_And_Save(x, PreprocessMSG)
            'Excel.Application.Wait Now + TimeValue("00:00:02")
            PreprocessItems.Item(x).Move UnprocessedDestFolder
                 
        End If
            
        'Excel.Application.Wait Now + TimeValue("00:00:04")
        
    Next x
    
Else
    Debug.Print "No unread items."

End If

Set processedItems = processedDestFolder.Items
Set UnprocessedItems = UnprocessedDestFolder.Items
Set ImageItems = ImageDestFolder.Items

Dim ProcessItemCount As Long
Dim UnprocessItemCount As Long
Dim ImageItemCount As Long

ProcessItemCount = processedItems.Count
UnprocessItemCount = UnprocessedItems.Count
ImageItemCount = ImageItems.Count

End Sub


Sub Check_File_Extension(RequiredBoolFileCheck, ImageBoolFileCheck, _
  UnprocessFileCheck, PreprocessMSG)
' Function for checking extension to define OOS and In scope

    RequiredBoolFileCheck = False
    ImageBoolFileCheck = False
    UnprocessFileCheck = False
    'i = 1
    
    Dim objAttachment As Object
    Dim filenamepre As String
    
    For Each objAttachment In PreprocessMSG.Attachments
    
        'filenamepre(i) = objAttachment.Filename
        filenamepre = objAttachment.Filename
        Debug.Print "filenamepre: " & filenamepre
        
        If LCase(Right(filenamepre, 4)) = "docx" Or _
          LCase(Right(filenamepre, 4)) = "xlsx" Or _
          LCase(Right(Trim(filenamepre), 3)) = "pdf" Or _
          LCase(Right(filenamepre, 3)) = "pdf" Or _
          LCase(Right(filenamepre, 3)) = "doc" Or _
          LCase(Trim(Right(filenamepre, 3))) = "xls" Or _
          LCase(Right(filenamepre, 3)) = "xls" Or _
          UCase(Right(filenamepre, 3)) = "CSV" Or _
          LCase(Right(filenamepre, 3)) = "odt" Or _
          LCase(Right(filenamepre, 3)) = "rtf" Or _
          LCase(Right(filenamepre, 4)) = "docm" Then
          
            RequiredBoolFileCheck = True
            Debug.Print " RequiredBoolFileCheck: " & RequiredBoolFileCheck
            
        ElseIf LCase(Right(filenamepre, 3)) = "jpg" Or _
          LCase(Right(filenamepre, 3)) = "tif" Or _
          LCase(Right(filenamepre, 4)) = "jpeg" Then
          
            ImageBoolFileCheck = True
            Debug.Print " ImageBoolFileCheck: " & ImageBoolFileCheck
            Exit For
            
        Else
            UnprocessFileCheck = True
            Debug.Print " UnprocessFileCheck: " & UnprocessFileCheck
            
        End If
        
        'i = i + 1
    Next objAttachment
    
End Sub


Sub Convert_And_Save(ByVal x As Long, PreprocessMSG As Object)

' Function to change the format and save to defined folder

    ' Reference Microsoft Word XX.X Object Library
    Dim wordApp As Word.Application
    Dim wordDoc As Word.Document
    
    Dim pdfName As String
    
    Dim savefolder As String
    savefolder = "S:\*****\RPA\OCR\OCRInputOutlook\"
    
    Dim objAttachment As Object
    Dim dateformat As String
    
    Dim FilePath As String
    
    For Each objAttachment In PreprocessMSG.Attachments
    
        If UCase(Right(objAttachment.Filename, 3)) = "PDF" Or _
          UCase(Right(Trim(objAttachment.Filename), 3)) = "PDF" Or _
          LCase(Right(Trim(objAttachment.Filename), 3)) = "pdf" Or _
          LCase(Right(objAttachment.Filename, 3)) = "pdf" Then
          
            dateformat = Format(Now, "yyyymmddHmmss")
            objAttachment.SaveAsFile savefolder & dateformat & _
              Replace(objAttachment.Filename, "-", "")
            Excel.Application.Wait Now + TimeValue("00:00:02")
            
        ElseIf UCase(Right(objAttachment.Filename, 4)) = "DOCX" Or _
          UCase(Right(objAttachment.Filename, 3)) = "DOC" Or _
          UCase(Right(objAttachment.Filename, 3)) = "RTF" Or _
          UCase(Right(objAttachment.Filename, 3)) = "ODT" Or _
          UCase(Right(objAttachment.Filename, 4)) = "DOCM" Then
          
            dateformat = Format(Now, "yyyymmddHmmss")
            FilePath = "S:\*****\RPA\OCR\Temp Path\" & objAttachment.Filename
            
            objAttachment.SaveAsFile (FilePath)
            'Excel.Application.Wait Now + TimeValue("00:00:02")
            Set wordApp = CreateObject("Word.Application")
            Set wordDoc = wordApp.Documents.Open(FilePath)
            
            pdfName = savefolder & Replace(objAttachment.Filename, "-", "") _
              & dateformat & ".pdf"
            wordDoc.ExportAsFixedFormat OutputFileName:=pdfName, ExportFormat:= _
              wdExportFormatPDF, OpenAfterExport:=False, _
              OptimizeFor:=wdExportOptimizeForPrint, _
              Range:=wdExportAllDocument, _
              Item:=wdExportDocumentContent, _
              IncludeDocProps:=True
            'Excel.Application.Wait Now + TimeValue("00:00:02")
            wordDoc.Close savechanges:=False
            wordApp.Quit
            Set wordApp = Nothing
            
         ElseIf UCase(Right(objAttachment.Filename, 4)) = "XLSX" Or _
           UCase(Right(objAttachment.Filename, 3)) = "XLS" Or _
           UCase(Right(objAttachment.Filename, 3)) = "CSV" Then
            
            dateformat = Format(Now, "yyyymmddHmmss")
            FilePath = "S:\*****\RPA\OCR\Temp Path\" & objAttachment.Filename
            
            objAttachment.SaveAsFile (FilePath)
            
            Dim wkb As Workbook
            Set wkb = Workbooks.Open(FilePath, editable:=True)
            
            Debug.Print " wkb.FullName: " & wkb.FullName
            Dim wkbFN As String
            wkbFN = wkb.FullName
            Debug.Print " wkbFN: " & wkbFN
            
            If Application.ProtectedViewWindows.Count > 0 Then
                Application.ActiveProtectedViewWindow.Edit
            End If
            
            Dim ws As Worksheet
            Set ws = Nothing
            savefolder = "S:\*****\RPA\OCR\OCRInputOutlook\"
            
            pdfName = savefolder & Replace(objAttachment.Filename, "-", "") & _
              dateformat & ".pdf"
            Debug.Print " pdfName: " & pdfName
            
            Dim cnt As Long
            cnt = 1
            
            For Each ws In wkb.Worksheets
            
                If Not ws.Visible = xlSheetHidden Then
              
                    If Not ws.Visible = xlSheetVeryHidden Then
                        If Not ws.UsedRange.Address = "$A$1" Then
                            ws.Copy
                            cnt = cnt + 1
                        End If
                    
                        Dim newWb As Workbook
                        Set newWb = ActiveWorkbook
                        
                        Debug.Print " newWb.FullName: " & newWb.FullName
                        
                        Dim newWs As Worksheet
                        Set newWs = newWb.ActiveSheet
                        
                        If cnt = 1 Then
                            newWs.ExportAsFixedFormat Type:=xlTypePDF, _
                              Filename:=pdfName, _
                              Quality:=xlQualityStandard, _
                              IncludeDocProperties:=True, _
                              IgnorePrintAreas:=False, _
                              OpenAfterPublish:=False
                        Else
                            pdfName = savefolder & Replace(objAttachment.Filename, "-", "") _
                              & dateformat & "_" & cnt & ".pdf"
                            Debug.Print " pdfName: " & pdfName
                            newWs.ExportAsFixedFormat Type:=xlTypePDF, _
                              Filename:=pdfName, _
                              Quality:=xlQualityStandard, _
                              IncludeDocProperties:=True, _
                              IgnorePrintAreas:=False, _
                              OpenAfterPublish:=False
                        End If
                        
                        Debug.Print " newWb.FullName: " & newWb.FullName
                        Debug.Print " wkb.FullName: " & wkb.FullName
                        
                        Debug.Print " wkbFN: " & wkbFN
                        If newWb.FullName = wkbFN Then
                            MsgBox wkbFN & " will be closed, perhaps prematurely."
                            wkbFN = ""
                        End If
                        
                        newWb.Close savechanges:=False
                        
                    Else
                        ws.Select

                        ws.ExportAsFixedFormat Type:=xlTypePDF, _
                          Filename:=pdfName, _
                          Quality:=xlQualityStandard, _
                          IncludeDocProperties:=True, _
                          IgnorePrintAreas:=False, _
                          OpenAfterPublish:=False
                    End If
                End If
            Next ws
            
            Debug.Print " wkbFN: " & wkbFN
            
            If wkbFN <> "" Then
                wkb.Save
                wkb.Close savechanges:=False
                
            Else
                MsgBox wkbFN & " was previously closed without saving."
                
            End If
            
        Else
        
            MsgBox "extension not listed"
            
        End If
    Next objAttachment
End Sub

Related Questions in EXCEL

Related Questions in VBA6

Trending Questions

Popular # Hahtags

javascript python java c# php android html jquery c++ css ios sql mysql r reactjs node.js arrays c asp.net json python-3.x ruby-on-rails .net sql-server swift django angular objective-c pandas excel

Popular Questions

Copyright © 2021 Jogjafile Inc.