lundi 30 mars 2015

Pull specific attachments from Outlook 2010 using VBA

I have managed to do the following vba codes but i am having issues with the restrict filter part where its picking up emails with RE: within the Subject for the 10pm and 5pm emails.


I would also like to copy the data within each open workbook into another workbook which is saved in another directory path.


The first data copied should include the header row and the remaining data copied from all other workbooks should not include the header row. The data needs to be pasted below the last row plus 1 into the workbook which is saved in another directory path


I would only like the current region to be copied from each workbook.


Sub DownloadAttachmentUnreadSubjectEmail()



Const olFolderInbox = 6
Const AttachmentPath As String = "\\lcwfsv1\users\e494356\My Documents\Outlook Test\"

Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolder.Folders("**CLIENT ISSUES**").Folders("*Daily Reports").Folders("1. Open Trade Report")

Set colItems = objFolder.Items
Set colFilteredItems1 = colItems.Restrict("[Unread] = True AND [Subject] = '10PM FXC Email notification'")
Set colFilteredItems2 = colItems.Restrict("[Unread] = True AND [Subject] = '5PMFXC Email notification'")

'~~> Check if there are any actual unread 10PM FXC emails
If colFilteredItems1.Count = 0 Then
MsgBox "NO Unread 10PM Email In Inbox"
Else
'~~> Extract the attachment from the 1st unread email
For Each colItems In colFilteredItems1
'~~> Check if the email actually has an attachment
If colItems.Attachments.Count <> 0 Then
For Each oOlAtch In colItems.Attachments
'~~> save the attachment and open them
oOlAtch.SaveAsFile AttachmentPath & oOlAtch.Filename
Set wb = Workbooks.Open(Filename:=AttachmentPath & oOlAtch.Filename)
Next oOlAtch
Else
MsgBox "10PM email doesn't have an attachment"
End If
Next colItems

End If

'~~> Check if there are any actual unread FXC Email emails
If colFilteredItems2.Count = 0 Then
MsgBox "NO Unread 5PM Email In Inbox"
Else
'~~> Extract the attachment from the 1st unread email
For Each colItems In colFilteredItems2
'~~> Check if the email actually has an attachment
If colItems.Attachments.Count <> 0 Then
For Each oOlAtch In colItems.Attachments
'~~> save the attachment and open them
oOlAtch.SaveAsFile AttachmentPath & oOlAtch.Filename
Set wb = Workbooks.Open(Filename:=AttachmentPath & oOlAtch.Filename)
Next oOlAtch
Else
MsgBox "5PM email doesn't have an attachment"
End If
Next colItems

End If


End Sub


Aucun commentaire:

Enregistrer un commentaire