Stuck at Outlook macro to loop in selection

[Ctrl+s]

Hi All,

I wanted to make an outlook macro which will go to each selected emails and insert comment. The macro is able to insert the comments for the first email in selection but not for the remaining. Is there any solutions. I am basically new to outlook vba.

I want to insert the comment for all the selected emails.

Any help is appreciated.

Below is the code which i have already

Sub insertcomment()
    
    
   '-------- Variable Declaration ---------
    Dim myolApp As Outlook.Application
    Dim msgReply As Outlook.MailItem
    Dim myNamespace As Outlook.NameSpace
    Dim usname As String
    
    
    Set myolApp = CreateObject("Outlook.Application")
    Set myNamespace = myolApp.GetNamespace("MAPI")
    
    '-------- to get the user Name ---------
    usname = myNamespace.CurrentUser

    '-------- Inputting Current User and Date & Time Stamp --------

    Set msgReply = ActiveExplorer.Selection.Item(1) '.Reply
    
    With msgReply
        .HTMLBody = "Processed by - " & usname & Space(2) & " - " & Format(Now, "dd-mmm-yyyy" & " - " & "hh:mm:ss AM/PM") & vbNewLine & .HTMLBody
   '.Display   '- use this if you want to display the email after inserting Date & Time Stamp
   
   
    End With
End Sub

 

[Domski]

This is how you would loop through selected emails I think:

Sub LoopMails()    
    Dim x As Long


    For x = 1 To ActiveExplorer.Selection.Count
        
        With ActiveExplorer.Selection.Item(x)
            If .Class = olMail Then
                MsgBox .Subject
            End If
        End With
    
    Next x
    
End Sub

Assuming you will have outlook open to select the email you don't need to mess about with creating a session of it etc.

Dom

 

[Ctrl+s]

This is how you would loop through selected emails I think:

Sub LoopMails()    
    Dim x As Long


    For x = 1 To ActiveExplorer.Selection.Count
        
        With ActiveExplorer.Selection.Item(x)
            If .Class = olMail Then
                MsgBox .Subject
            End If
        End With
    
    Next x
    
End Sub

Assuming you will have outlook open to select the email you don't need to mess about with creating a session of it etc.

Dom

Thank you very much for the reply.

I have included the above logic with the code. But, it is still inserting the comment in first email only but not rest.

here is my modified code.

Sub insertcomments()
    Dim x As Long
    Dim myNamespace As Outlook.NameSpace
    Dim usname As String
    
    
    
    Set myolApp = CreateObject("Outlook.Application")
    Set myNamespace = myolApp.GetNamespace("MAPI")


usname = myNamespace.CurrentUser

    For x = 1 To ActiveExplorer.Selection.Count
        
        With ActiveExplorer.Selection.item(x)
            If .Class = olMail Then
                'MsgBox .Subject
                .HTMLBody = "Processed by - " & usname & Space(2) & " - " & Format(Now, "dd-mmm-yyyy" & " - " & "hh:mm:ss AM/PM") & vbNewLine & .HTMLBody
            End If
        End With
    
    Next x
    
End Sub

 

[Domski]

Hi again,

Try this:

Sub LoopMails()    
    Dim x As Long
    Dim mlItm As Outlook.MailItem
    Dim myNamespace As Outlook.NameSpace


    Set myNamespace = Application.GetNamespace("MAPI")


    With ActiveExplorer.Selection
        For x = 1 To .Count
            If .Item(x).Class = olMail Then
                Set mlItm = .Item(x)
                If mlItm.BodyFormat = olFormatHTML Then
                    mlItm.HTMLBody = "Processed by - " & myNamespace.CurrentUser & " - " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & "<p>" & mlItm.HTMLBody
                Else
                    mlItm.Body = "Processed by - " & myNamespace.CurrentUser & " - " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & vbCrLf & mlItm.Body
                End If
                If Not mlItm.Saved Then
                    mlItm.Save
                End If
            End If
        Next x
    End With
    
End Sub

Dom

 

[Ctrl+s]

Hi again,

Try this:

Sub LoopMails()    
    Dim x As Long
    Dim mlItm As Outlook.MailItem
    Dim myNamespace As Outlook.NameSpace


    Set myNamespace = Application.GetNamespace("MAPI")


    With ActiveExplorer.Selection
        For x = 1 To .Count
            If .Item(x).Class = olMail Then
                Set mlItm = .Item(x)
                If mlItm.BodyFormat = olFormatHTML Then
                    mlItm.HTMLBody = "Processed by - " & myNamespace.CurrentUser & " - " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & "<p>" & mlItm.HTMLBody
                Else
                    mlItm.Body = "Processed by - " & myNamespace.CurrentUser & " - " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & vbCrLf & mlItm.Body
                End If
                If Not mlItm.Saved Then
                    mlItm.Save
                End If
            End If
        Next x
    End With
    
End Sub

Dom

Hi Dom,

Thank you so much. It is working fine.

 

[Bryen6611]

Hi again,

Try this:

Sub LoopMails()    
    Dim x As Long
    Dim mlItm As Outlook.MailItem
    Dim myNamespace As Outlook.NameSpace


    Set myNamespace = Application.GetNamespace("MAPI")


    With ActiveExplorer.Selection
        For x = 1 To .Count
            If .Item(x).Class = olMail Then
                Set mlItm = .Item(x)
                If mlItm.BodyFormat = olFormatHTML Then
                    mlItm.HTMLBody = "Processed by - " & myNamespace.CurrentUser & " - " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & "<p>" & mlItm.HTMLBody
                Else
                    mlItm.Body = "Processed by - " & myNamespace.CurrentUser & " - " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & vbCrLf & mlItm.Body
                End If
                If Not mlItm.Saved Then
                    mlItm.Save
                End If
            End If
        Next x
    End With
    
End Sub

Dom

Hey Dom!
Thank you so much, It works for me also...