excelvbaoutlook

How to Open Insert Item Dialog From Outlook Using VBA


My project requires user to select and attach a existing mail from Outlook to new mail. I am trying to find how to get the below dialog to show in outlook using VBA to allow user to select the mail to attach. Could anyone guide me.

enter image description here

I tried to look at outlook object if it supports showing any such dialog through VBA but could not find any way to display it.


Solution

  • I solved it myself after a lot of trial and error. Here is my solution.

    It demonstrates how to attach an email to a new email as well as how to get email item selection from user input and then save all the attachments from that email. Hope it is helpful.

    Dim FilePath As String
        
    Function getUserEmailSelection() As Object
        Dim o As Object, mailWindow As Object
        Dim myItem As Object, objMsg As Object, oA As Object
        Set o = CreateObject("Outlook.Application")
        FilePath = Environ("TEMP") & "\" & Format(Now, "yyyy-mm-dd H-mm") & " "
        
        Set objMsg = o.CreateItem(0)
        Set mailWindow = objMsg.GetInspector
        mailWindow.Display
        mailWindow.WindowState = 1
        mailWindow.CommandBars.ExecuteMso "AttachItem"
        
        On Error GoTo DialogCancelled
        Set oA = objMsg.Attachments(1)
        objMsg.Close 1
        Set mailWindow = Nothing
        On Error GoTo 0
        
        FilePath = FilePath & oA.Filename
        oA.SaveAsFile FilePath
        Set myItem = o.CreateItemFromTemplate(FilePath)
        Set getUserEmailSelection = myItem
        
        Exit Function
        
        DialogCancelled:
        Err.Clear
        objMsg.Close 1
        Set getUserEmailSelection = Nothing
    End Function
    

    For Testing, here is the code:

    Sub SaveAllAttachments()
        Dim olMail As Object, objAttachments As Object, lngCount As Long
        Dim strFolderpath As String, strFile As String, i As Long
        strFolderpath = "C:\Users\BD\Local\New folder\"
        Set olMail = getUserEmailSelection()
        If Not olMail Is Nothing Then
        Set objAttachments = olMail.Attachments
            lngCount = objAttachments.Count
            If lngCount > 0 Then
                For i = lngCount To 1 Step -1
                    strFile = objAttachments.Item(i).Filename
                    strFile = strFolderpath & strFile
                    objAttachments.Item(i).SaveAsFile strFile
                Next
            End If
        Kill FilePath
        End If
    End Sub