Forum Discussion

klakiklaki's avatar
klakiklaki
Copper Contributor
Dec 28, 2024

Run macro after new email

Is it possible to enable automatic macro execution (run macro) every time a new email arrives? Can something like: Private Sub Application_Startup / Triggered() be added to the code? Or at least add a command for the macro to click the blue button = (run macro) every time a new email arrives or to automatically click it every 3''? (To automatically repeat the action '- run macro - every 3'' (3 seconds)? I thought the whole code should remain only in excel so that it doesn't have to be entered into outlook?

Here is the code that works but only when the blue button is clicked.

https://raw.githubusercontent.com/santhosh2r2/youtube/7d3490f62aa5e8f4daa90e28bbb09523d0f6bd98/03_Tech_Tips/41_Import_Outlook_Email.vba.txt

https://www.youtube.com/watch?v=KDmYawgx20I 

 

'Clear the range contents Sub Clear_Range() Dim lastRow As Integer lastRow = Cells(Rows.Count, 1).End(xlUp).Row If lastRow > 4 Then ActiveSheet.Range("A5:D" & lastRow).ClearContents End If End Sub 'Import E-Mails from Outlook subroutine Sub Import_Emails() 'Empty the range Clear_Range 'Create an Outlook Application object Dim OutlookApp As Outlook.Application 'Create an Namespace object Dim OutlookNamespace As Namespace 'Create a Outlook folder object Dim Folder As MAPIFolder 'Object to store the retrieved E-Mails Dim OutlookItems As Outlook.items 'Temporary object, used for iteration Dim OutlookMail As Variant 'Get the folder name from excel sheet Dim FolderName As String FolderName = ActiveSheet.Range("D1").Value 'Create an instance of Outlook Set OutlookApp = New Outlook.Application 'Set the namespace Set OutlookNamespace = OutlookApp.GetNamespace("MAPI") 'Error handling On Error GoTo ExitSub 'If the checkbox is not checked, then the folder is at the same level as inbox If ActiveSheet.OLEObjects("check").Object.Value = False Then Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Forex").Folders("Majors").Folders("USDJPY") End If 'If the checkbox is active, then it is a sub-folder of inbox If ActiveSheet.OLEObjects("check").Object.Value = True Then Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Forex").Folders("Majors").Folders("USDJPY") End If 'Get the folder items and sort according to the recieved time Set OutlookItems = Folder.items OutlookItems.Sort "ReceivedTime", True 'Results counter starting from Row 5 Dim i As Integer i = 5 'Print the output For Each OutlookMail In OutlookItems If OutlookMail.ReceivedTime >= ActiveSheet.Range("B1").Value Then ActiveSheet.Cells(i, 1).Value = OutlookMail.ReceivedTime ActiveSheet.Cells(i, 2).Value = OutlookMail.SenderName ActiveSheet.Cells(i, 3).Value = OutlookMail.Subject ActiveSheet.Cells(i, 4).Value = OutlookMail.Body i = i + 1 End If Next OutlookMail 'Display the total number of e-mails retrieved ActiveSheet.Range("B2").Value = i - 5 ActiveSheet.Range("B2").Font.Color = vbBlack 'Reset the obejcts Set OutlookItems = Nothing Set Folder = Nothing Set OutlookNamespace = Nothing Set OutlookApp = Nothing Exit Sub 'Error handling function ExitSub: ActiveSheet.Range("B2").Value = "Folder name not found" ActiveSheet.Range("B2").Font.Color = vbRed Set OutlookItems = Nothing Set Folder = Nothing Set OutlookNamespace = Nothing Set OutlookApp = Nothing End Sub 

 

excel
Macros and VBA

1 Reply

  • Kidd_Ip's avatar
    Kidd_Ip
    MVP
    Jan 02, 2025

    Try below

    Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Set Ns = Application.GetNamespace("MAPI")
    Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        Call RunExcelMacro
    End If
End Sub

Private Sub RunExcelMacro()
    Dim xlApp As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Workbooks.Open "C:\Workbook.xlsx"
    xlApp.Run "Import_Emails"
    xlApp.Quit
    Set xlApp = Nothing
End Sub

     

Resources