Mails

gistfile1.txt

Sub ImportEmailsFromOutlook()
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim Folder As Object
    Dim MailItem As Object
    Dim i As Integer
    Dim Subject As String
    Dim ws As Worksheet
    Dim FolderName As String
    Dim FolderPath As String
    Dim MailboxName As String

    ' Set mailbox and folder details
    MailboxName = "YourMailboxName" ' Update this with your actual mailbox name
    FolderPath = "Inbox\SpecificFolder" ' Update this with your folder path

    ' Create a new Outlook Application object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' Try to access the folder
    On Error Resume Next
    Set Folder = OutlookNamespace.Folders.Item(MailboxName)
    If Folder Is Nothing Then
        MsgBox "Mailbox not found!"
        Exit Sub
    End If
    
    ' Try to access the specific folder
    Set Folder = Folder.Folders.Item("Inbox")
    If Folder Is Nothing Then
        MsgBox "Inbox not found!"
        Exit Sub
    End If
    
    Set Folder = Folder.Folders.Item("SpecificFolder")
    If Folder Is Nothing Then
        MsgBox "Specific Folder not found!"
        Exit Sub
    End If
    On Error GoTo 0 ' Reset error handling

    ' Set reference to the Excel sheet (adjust the sheet name)
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' Clear any existing data in the sheet
    ws.Cells.Clear

    ' Loop through the emails in the folder
    i = 1
    For Each MailItem In Folder.Items
        If TypeName(MailItem) = "MailItem" Then
            ' Get the subject of the email
            Subject = MailItem.Subject
            
            ' Insert the email subject into the cell
            ws.Cells(i, 1).Value = Subject
            
            ' Insert a button to link to the email
            Set Item = ws.Buttons.Add(Left:=ws.Cells(i, 2).Left, Top:=ws.Cells(i, 2).Top, Width:=100, Height:=20)
            Item.OnAction = "OpenEmail" ' Assign the action to open the email
            Item.Caption = "Open Email"
            Item.Name = "btn" & i ' Make the button unique by using the row number
            
            ' Save the entry with a reference to the email item
            ws.Cells(i, 3).Value = MailItem.EntryID ' Store the unique email ID in column 3
            
            i = i + 1
        End If
    Next MailItem
End Sub

Sub OpenEmail()
    Dim OutlookApp As Object
    Dim OutlookNamespace As Object
    Dim MailItem As Object
    Dim EmailID As String
    Dim ws As Worksheet
    Dim button As Object
    Dim row As Long
    Dim buttonName As String

    ' Get the active sheet and the row of the button
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Get the name of the button that was clicked
    buttonName = Application.Caller
    
    ' Extract the row number from the button name (assuming button name format is "btnX")
    row = Mid(buttonName, 4) ' Extracts the number from "btnX" (e.g., "btn1" becomes 1)

    ' Get the stored email ID from the third column of the corresponding row
    EmailID = ws.Cells(row, 3).Value
    
    ' Create a new Outlook Application object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' Retrieve the email using its unique EntryID
    Set MailItem = OutlookNamespace.GetItemFromID(EmailID)
    
    ' Open the email
    MailItem.Display
End Sub