https://www.slipstick.com/outlook/email/save-open-attachment/
Private Declare Function GetShortPathName Lib "kernel32" _ Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Private Sub objItems_ItemAdd(ByVal Item As Object) Dim objMail As Outlook.MailItem Dim objWsShell As Object Dim strTempFolder As String Dim objAttachments As Outlook.Attachments Dim objAttachment As Attachment Dim strFileName As String Dim Subject As String Subject = Item.Subject 'If Subject Like "*SubTest*" Then If Item.Class = olMail Then Set objMail = Item 'Change sender email address 'If objMail.SenderEmailAddress = "boss@datanumen.com" Then Set objWShell = CreateObject("WScript.Shell") strTempFolder = Environ("Temp") & "\" Set objWsShell = CreateObject("WScript.Shell") Set objAttachments = objMail.Attachments If objAttachments.Count > 0 Then For Each objAttachment In objAttachments strFileName = objAttachment.DisplayName On Error Resume Next Kill strTempFolder & strFileName On Error GoTo 0 'Save the attachment objAttachment.SaveAsFile strTempFolder & strFileName 'Open the attachment strFileName = GetShortFileName(strTempFolder & strFileName) On Error Resume Next objWsShell.Run strFileName Next 'End If End If End If 'End If End Sub Function GetShortFileName(ByVal FullPath As String) As String Dim lAns As Long Dim sAns As String Dim iLen As Integer On Error Resume Next If Dir(FullPath) <> "" Then sAns = Space(255) lAns = GetShortPathName(FullPath, sAns, 255) GetShortFileName = Left(sAns, lAns) End If End Function
Open Spreadsheet and Run Macro:
(Note: Requires "runmacro.vbs")
'Open the attachment vbs = (Chr(34) & "\\Server\Excel\" & "\runmacro.vbs " & Chr(34)) strFileName = GetShortFileName(strTempFolder & strFileName) macro = "MacroName" xlam = Environ("APPDATA") & "\Microsoft\Excel\XLSTART\Add-In.xlam" On Error Resume Next objWsShell.Run vbs & " " & strFileName & " " & macro & " " & xlam objMail.UnRead = False