VBA Excel to auto reply email based on subject in the excel cells-CodePudding

I have created the below code for to reply based on the email subject that listed on the excel cells, however it cannot loop through the cells. It can only reply 1 email and cannot continue to the next step. Please help to check the code below. Thank you.

 Sub Display()

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
Signature = Signature & Dir$(Signature & "*.htm")
Else:
Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)

IsExecuted = False


i = 2
For Each olMail In Fldr.Items
If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then

    With olMail.Reply

.HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody

.Display

  End With
i = i   1
End If


Next olMail

End Sub

CodePudding user response：

You change rows before checking all items.

You could move i = i 1 after Next olMail but you would need additional code to complete the second loop.

Instead apply another For loop.

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant


Sub Display()

' Early binding
' Set reference to Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.Folder

Dim olMail As Object

Dim i As Long
Dim lastRow As Long

Dim Signature As String

Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
    Signature = Signature & Dir$(Signature & "*.htm")
Else
    Signature = ""
End If

Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)

' https://stackoverflow.com/questions/38882321/better-way-to-find-last-used-row
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Debug.Print
Debug.Print "lastRow:" & lastRow

For i = 2 To lastRow

    Debug.Print
    Debug.Print i & "- " & ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value
    
    For Each olMail In Fldr.Items
        
        Debug.Print "  " & olMail.Subject
        
        If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then
            With olMail.Reply
                .HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
                Debug.Print "*** match ***"
                .Display
            End With
        End If

    Next olMail
    
Next

End Sub

CodePudding user response：

Outlook folders may contain different kind of items. So, when you iterate over all items in the folder you may deal with different items - appointments, documents, notes and etc. To make sure that you deal with mail items only I'd recommend checking the MessageClass property of the item before accessing item-specific properties at runtime. Otherwise, an error will be raised and your loop will never come to the end.