Attachment Download

[vmjan02]

I have the below code and have it is on Outlook VBA on ThisOutlookSession

But I am still not able to download the attachments in the folder, I am trying this for quite a while now but no luck, did
google as well. It is not showing any error, but still not downloading the attachment in the folder

Help please.

Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
   Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
   Dim objMail As Outlook.MailItem
   Dim strSenderAddress As String
   Dim strSenderDomain As String
   Dim objAttachment As Attachment
   Dim strFolderPath As String
   Dim strFileName As String


   If Item.Class = olMail Then
      Set objMail = Item


      'Get sender domain
      strSenderAddress = objMail.SenderEmailAddress
      strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "@"))


      'Change to the specific domain as per your needs
      If strSenderDomain = "vs@gmail.com" Then
         If objMail.Attachments.Count > 0 Then
            For Each objAttachment In objMail.Attachments


                strFolderPath = "E:\Performance Report\"
                strFileName = objMail.Subject & " " & Chr(45) & " " & objAttachment.FileName
                objAttachment.SaveAsFile strFolderPath & strFileName
            Next
         End If
      End If
   End If
End Sub

 

[DanteAmor]

Hi @vmjan02,

It is in the main inbox folder or it is in some subfolder.
The macro works for me and for the user who requested it on the link.

Remove this line from the macro and execute step by step and tell me what error message appears.

On Error Resume Next

Do you have outlook? what version?


If the files are in a subfolder check this:
https://www.mrexcel.com/forum/gener...097631-count-emails-outlook-export-excel.html

 

[vmjan02]

did removed the code "on Error Resume Next"
There is no error at all it just it asked for the folder selection and then msgbox "Done"

Using Outlook 2010. and there is no subfolder its in the inbox folder

 

[ZVI]

no

The code requirs full Outlook's path from the root to the Folder with subfolders.
Could you post it?
If it is a common folder then code may not work, it depends on server configuration

 

[vmjan02]

The code requirs full Outlook's path from the root to the Folder with subfolders.
Could you post it?
If it is a common folder then code may not work, it depends on server configuration

vs@gmail.com\Inbox\...

 

[ZVI]

And please do you have 1 or more accounts?

 

[DanteAmor]

did removed the code "on Error Resume Next"
There is no error at all it just it asked for the folder selection and then msgbox "Done"
Using Outlook 2010. and there is no subfolder its in the inbox folder

Try this please:

Run the macro and select the folder that contains the emails.

Sub download_attachments()
  Dim olApp As Outlook.Application, olmail As MailItem, Att As Object
  Dim olFolder As Outlook.Folder, sPath As String, y As Long, strfile As String
  sPath = ThisWorkbook.Path & "\"
  '
  Set olApp = CreateObject("Outlook.application")
  Set olmail = olApp.CreateItem(olMailItem)
  Set olFolder = olApp.GetNamespace("MAPI").PickFolder
  '
  For Each olmail In olFolder.Items
    If TypeName(olmail) = "MailItem" Then
      y = 1
      For Each Att In olmail.Attachments
        strfile = sPath & olmail.Attachments.Item(y).Filename
        olmail.Attachments.Item(y).SaveAsFile strfile
        y = y + 1
      Next Att
    End If
  Next
  MsgBox "Done"
End Sub

 

[ZVI]

Well, does the below code work?

Option Explicit

Public WithEvents objInboxItems As Outlook.Items

' Run this code manually for the testing or reload Outlook
Private Sub Application_Startup()
   Const GmailAccountName = "...@gmail.com" ' <-- put gmail root folder name (actually it's gmail email)
   Set objInboxItems = Application.GetNamespace("MAPI").Folders(GmailAccountName).Folders("Inbox").Items
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
  MsgBox "Ok"
  ' Your code is here
  '...
End Sub

 

[ZVI]

The below code works with any input emails independently of input folder:

' Code of ThisOutlookSession
Option Explicit

Private Sub Application_Startup()
' Do nothing, but this tries to enable macros or asks to confirm it
End Sub

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
  
  Dim objItem As Object
  Dim objMail As MailItem
  
  Set objItem = Application.GetNamespace("MAPI").GetItemFromID(EntryIDCollection)
  If objItem.Class <> olMail Then Exit Sub
  Set objMail = objItem
  
  ' This is just for the testing
  MsgBox "Message subject: " & objMail.Subject & vbLf _
       & "Message sender: " & objMail.SenderName & " (" & objMail.SenderEmailAddress & ")"
  
  ' Your code goes here
  ' ...
  
  
  ' Release memory of the object variables
  Set objItem = Nothing
  Set objMail = Nothing
  
End Sub

 

[vmjan02]

And please do you have 1 or more accounts?

1 account

 

[ZVI]

Does code from post 17 or 18 work?