I've been trying to find a script that saves attachments to a folder on our network from Outlook. I've finally got something working but it looks like it doesn't work on my 2nd system which happens to be Outlook 2010. I can't say for sure if it's because of this difference.
Code is:
Sub SaveAllAttachments(objItem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "C:\test\"
On Error GoTo ExitSub
If objItem.Class = olMail Then
Set objAttachments = objItem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
For dblLoop = 1 To dblCount
strID = " from " & Format(Date, "mm-dd-yy") 'Append the Date
'strID = strID & " at " & Format(Time, "hh`mm AMPM") 'Append the Time
' These lines are going to retrieve the name of the
' attachment, attach the strID to it to insure it is
' a unique name, and then insure that the file
' extension is appended to the end of the file name.
strName = objAttachments.Item(dblLoop).Filename 'Get attachment name
strExt = Right$(strName, 4) 'Store file Extension
strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName1 = strLocation & "PDF\" & strName 'Put it all together
strName2 = strLocation & "JPG\" & strName 'Put it all together
' Save the attachment as a file.
objAttachments.Item(dblLoop).SaveAsFile strName1
objAttachments.Item(dblLoop).SaveAsFile strName2
Next dblLoop
objItem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
It doesn't matter what Outlook version you are using at the moment. The code should work correcly.
Possible reasons why it doesn't work:
I'd suggest choosing another location for saving files. The C: drive requires admin privileges on latest OS.
The rule is not triggered.
An error in the script. Try to call the script manually from other VBA sub and see what happens under the hood. Do you get any errors in the code?
Related
I'm completely new to VB and I'm trying to extract the attachment which is saved available inside the .msg file using the below code.
Could someone help me if this is the right approach to do this ?
I'm facing below compiler errors. Could someone help me how to resolve this issue ?
Outlook.Attachment is not defined.
End Sub' must be preceded by a matching 'Sub'
Reference to a non-shared member requires an object reference.
Statement cannot appear within a method body. End of method assumed
Method arguments must be enclosed in parentheses.
Type 'Outlook.MailItem' is not defined.
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
Dim strFile As String
strFilePath = "C:\Users\...\Desktop\Test\"
strAttPath = "C:\Users\...\extracted attachment\"
strFile = Dir(strFilePath & "<Doc Name>.msg")
Do While Len(strFile) > 0
msg = Application.CreateItemFromTemplate(strFilePath & strFile)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
strFile = Dir
Loop
End Sub
First of all, check out the file path where you try to find the template:
msg = Application.CreateItemFromTemplate(strFilePath & strFile)
The strFilePath string may include the file name already:
strFile = Dir(strFilePath & "<Doc Name>.msg")
Second, make sure attachments are saved using unique file names:
att.SaveAsFile strAttPath & att.FileName
The FileName string can be the same in different emails. I'd recommend adding IDs or the current time and etc. to the file name to uniquely name attached files on the disk.
Here is the code we use to grab a daily report attachment. I left a few commented statements in case you might need them (we didn't).
Sub Extract_Outlook_Email_Attachments()
On Error GoTo ErrHandler
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim olNS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Dim saveFolder As String
saveFolder = strAttPath ' SAVE THE ATTACHMENT TO
'this bit is added to get a shared email
Set objOwner = OutlookNamespace.CreateRecipient("SHARED FOLDER NAME")
objOwner.Resolve
If objOwner.Resolved Then
Debug.Print "Outlook GB Fulfillment is good."
Set folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) 'can use olFolderInbox or olFolderSentMail
End If
'Write mail to spreadsheet - create named range, from and to dates on the spreadsheet
i = 1
For Each OutlookMail In folder.Items
' Debug.Print "SenderEmailAddress: " & OutlookMail.SenderEmailAddress
'If OutlookMail.SenderEmailAddress = "no-reply#OurCompany.com" Then
If OutlookMail.subject = "Daily Report" Then
' If OutlookMail.SenderName = "no-reply#OurCompany.com" And OutlookMail.Subject = "Daily New Subscriber Plan Election Fulfillment" And OutlookMail.Attachments(1) = "NewSubscriberPlanElectionFulfillment_Subscription.xls" Then
Debug.Print "Received: " & OutlookMail.ReceivedTime
Debug.Print "Attach: " & OutlookMail.Attachments(1)
dateformat = Format(OutlookMail.ReceivedTime, "m-d-yy")
Debug.Print dateformat
FName = dateformat & " " & OutlookMail.Attachments(1).fileName
Debug.Print "FName: " & FName
Dim strFileExists As String
strFileExists = Dir(saveFolder & FName)
If strFileExists = "" Then
' MsgBox "The selected file doesn't exist"
Else
' MsgBox "The selected file exists"
Exit Sub
End If
OutlookMail.Attachments(1).SaveAsFile saveFolder & FName
Set outAttachment = Nothing
End If
Next OutlookMail
Set folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
ErrHandler:
Debug.Print Err.Description
End Sub
Instead of using CreateItemFromTemplate, you can use Namespace.OpenSharedItem to open an MSG file.
You also need to add Outlook to your VB.Net project references.
I am rather new to VBA and was hoping to get some help on a project. To give you some background, I get an email in outlook about every 15 minutes with an excel attachment. I need to open the attachment once the email gets in and view it / compare it to the email that was sent 15 minutes prior. If there is a difference in the emails then I must preform an action. I was hoping to automate at least some of this process. Ideally, I could use a macro to scan my inbox for any new message from a particular sender. If it finds a message it could then check for an attachment and if the attachment is there it would download and open it.
In an ideal world the other thing I could do is compare the prior excel attachment to the current one and ping a message (alert) if it is different.
Any help would be much appreciated. As I said, I am new to VBA but I am trying my best to understand functions.
This should get you started. Assuming you have selected the e-mail in outlook:
Sub check_for_changes()
'Created by Fredrik Östman www.scoc.se
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = myOlApp.Explorers.Item(1)
Set myOlSel = myOlExp.Selection
Set mymail = myOlSel.Item(1)
Dim myAttachments As Outlook.Attachments
Set myAttachments = mymail.Attachments
Dim Atmt As Attachment
Set Atmt = myAttachments(1)
new_file_name = "C:\tmp\new_received_file.xlsx"
old_file_name = "C:\tmp\old_received_file.xlsx"
FileCopy new_file_name, old_file_name
Atmt.SaveAsFile new_file_name
Dim eApp As Object
Set eApp = CreateObject("Excel.Application")
eApp.Application.Visible = True
Dim new_file As Object
eApp.workbooks.Open new_file_name
Set new_file = eApp.ActiveWorkbook
Dim old_file As Object
eApp.workbooks.Open old_file_name
Set old_file = eApp.ActiveWorkbook
'Find range to compare
start_row = old_file.sheets(1).usedrange.Row
If new_file.sheets(1).usedrange.Row > start_row Then start_row = new_file.sheets(1).usedrange.Row
end_row = old_file.sheets(1).usedrange.Row + old_file.sheets(1).usedrange.Rows.Count
If new_file.sheets(1).usedrange.Rows.Count + new_file.sheets(1).usedrange.Row > end_row Then end_row = new_file.sheets(1).usedrange.Rows.Count + new_file.sheets(1).usedrange.Row
start_col = old_file.sheets(1).usedrange.Column
If new_file.sheets(1).usedrange.Column > start_col Then start_col = new_file.sheets(1).usedrange.Column
end_col = old_file.sheets(1).usedrange.Column + old_file.sheets(1).usedrange.Columns.Count
If new_file.sheets(1).usedrange.Columns.Count + new_file.sheets(1).usedrange.Column > end_row Then end_row = new_file.sheets(1).usedrange.Columns.Count + new_file.sheets(1).usedrange.Column
'Check all cells
something_changed = False
For i = start_row To end_row
For j = start_col To end_col
If new_file.sheets(1).Cells(i, j) <> old_file.sheets(1).Cells(i, j) Then
new_file.sheets(1).Cells(i, j).Interior.ColorIndex = 3 'Mark red
something_changed = True
End If
Next j
Next i
If something_changed Then
new_file.Activate
Else
new_file.Close
old_file.Close
If eApp.workbooks.Count = 0 Then eApp.Quit
MsgBox "No changes"
End If
End Sub
Interesting question, I'll get you started with the outlook part. You'll probably want to split the question between Outlook and Excel.
Here is some code I use to save every attachment I have been sent in Outlook to save space.
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim pobjMsg As Outlook.MailItem 'Object
Dim objSelection As Outlook.Selection
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
For Each pobjMsg In objSelection
SaveAttachments_Parameter pobjMsg
Next
ExitSub:
Set pobjMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
MsgBox "Export Complete"
End Sub
Public Sub SaveAttachments_Parameter(objMsg As MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "C:\Users\******\Documents\Reports\"
'On Error Resume Next
' Set the Attachment folder.
strFolderpath = strFolderpath & "Outlook Attachments\"
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' We need to use a count down loop for removing items' from a collection. Otherwise, the loop counter gets' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
If Right(strFile, 4) = ".png" Or Right(strFile, 4) = ".jpg" Or Right(strFile, 4) = ".gif" Then
GoTo cont
End If
' Combine with the path to the Temp folder.
strFile = strFolderpath & objMsg.SenderName & "." & Format(objMsg.ReceivedTime, "yyyy-MM-dd h-mm-ss") & "." & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment - You might not want this part
'objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat = olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & Replace(strFile, " ", "%20") & ">"
Else
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & Replace(strFile, " ", "%20") & ">"
End If
cont:
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat = olFormatHTML Then
objMsg.Body = "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.HTMLBody
End If
objMsg.Save
End If
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub
The part in the code which says
If Right(strFile, 4) = ".png" Or Right(strFile, 4) = ".jpg" Or Right(strFile, 4) = ".gif" Then
GoTo cont
you could change to something like:
If objMsg.SenderName = "John Smith" Then
GoTo cont
that way it will only save the attachment from that specific sender.
Then, once you have two or more files, you can load the files using another macro in excel and compare the two files, then send you an email if there are any discrepancies.
Hope that gets you started.
I am trying to save outlook attachments to a folder and where the filename already exists save the newer file under a different name so as not to save over the existing file....perhaps just give an extension "v2" or even "v3" if "v2" exists.
I came across this answer but am finding that the newer file is saved over the existing file
Save attachments to a folder and rename them
I have used the below code;
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
strFolderpath = "C:\Users\Owner\my folder is here"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
strFolderpath = strFolderpath & "\my subfolder is here\"
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
I am relatively new to vba so perhaps the solution is there but am not seeing it!
Take a look at my code below. It goes through all of the items in a specific Outlook folder (that you designate), goes through each attachment in each item, and saves the attachment in a specified file path.
'Establish path of folder you want to save to
Dim FilePath As Variant
FilePath = "C:\Users\Owner\my folder is here\my subfolder is here\"
Set FSOobj = CreateObject("Scripting.FilesystemObject")
'If path doesn't exist, create it. If it does, either do nothing or delete its contents
If FSOobj.FolderExists(FilePath) = False Then
FSOobj.CreateFolder FilePath
Else
' This code is if you want to delete the items in the existing folder first.
' It's not necessary for your case.
On Error Resume Next
Kill FilePath & "*.*"
On Error GoTo 0
End If
'Establish Outlook folders, attachments, and other items
Dim msOutlook As Outlook.NameSpace 'Establish Outlook NameSpace
Dim Folder As Outlook.MAPIFolder 'Establish Folder as a MAPIFolder
Dim messageAttachments As Outlook.Attachments
Set msOutlook = Application.GetNamespace("MAPI")
'Set the folder that contains the email with the attachment
Set Folder = msOutlook.GetDefaultFolder(olFolderInbox).Folders("FOLDER NAME HERE")
Set folderItems = Folder.Items
Dim folderItemsCount As Long
folderItemsCount = folderItems.Count
Dim number as Integer
number = 1
For i = 1 To folderItemsCount
'If you want to pull the attachments on some criteria, like the Subject of the email or
'the date received, you need to write an IF statement like:
'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then
Set messageAttachments = folderItems.item(i).Attachments
lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message
For thisAttachment = 1 To lngCount
messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx"
number = number + 1
Next thisAttachment
Next i
EDIT
In order to delete the items after scraping the attachments, you would use the same code as above except you would also include folderItems.item(i).Delete. Also, since you are moving items, I switched to looping backwards in your for loop as to not mess up your iteration. I've written it below:
For i = folderItemsCount To 1 Step -1
'If you want to pull the attachments on some criteria, like the Subject of the email or
'the date received, you need to write an IF statement like:
'If InStr(Folder.Items(i).Subject, "SPECIFIC SUBJECT TEXT") Then
Set messageAttachments = folderItems.item(i).Attachments
lngCount = messageAttachments.Count 'This lets you pull more than one attachment per message
For thisAttachment = 1 To lngCount
messageAttachments.item(thisAttachment).SaveAsFile FilePath & "YOUR_CHOSEN_FILENAME" & number & ".xlsx"
number = number + 1
Next thisAttachment
folderItems.item(i).Delete
Next i
I hope this helps!
The Excel code below is designed to go to a webpage, search a hyperlink and download PDF file under it and save it on desktop.
I need to amend it for Outlook:
So that it detects a Sender email, e.g. generic#gmail.com
Detect the hyperlink in the email and on the webpage to detect a button 'Export Details' and press it
Then on next page press 'Export' button and save CVS file on Desktop: "C:\Users\mlad1406\Desktop\Test".
Sub DownPDF()
' This macro downloads the pdf file from webpage
' Need to download MSXML2 and MSHTML parsers and install
Dim sUrl As String
Dim xHttp As MSXML2.XMLHTTP
Dim hDoc As MSHTML.HTMLDocument
Dim hAnchor As MSHTML.HTMLAnchorElement
Dim Ret As Long
Dim sPath As String
Dim i As Long
sPath = "C:\Users\mlad1406\Desktop\Test"
sUrl = "https://copernicus.my.salesforce.com/00O20000006WD95"
'Get the directory listing
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", sUrl
xHttp.Send
'Wait for the page to load
Do Until xHttp.readyState = 4
DoEvents
Loop
'Put the page in an HTML document
Set hDoc = New MSHTML.HTMLDocument
hDoc.Body.innerHTML = xHttp.responseText
'Loop through the hyperlinks on the directory listing
For i = 0 To hDoc.getElementsByTagName("a").Length - 1
Set hAnchor = hDoc.getElementsByTagName("a").Item(i)
'test the pathname to see if it matches your pattern
If hAnchor.PathName Like "Ordin-*.2013.pdf" Then
Ret = UrlDownloadToFile(0, sUrl & hAnchor.PathName, sPath, 0, 0)
If Ret = 0 Then
Debug.Print sUrl & hAnchor.PathName & " downloaded to " & sPath
Else
Debug.Print sUrl & hAnchor.PathName & " not downloaded"
End If
End If
Next i
End Sub
Here is some code, that should help you to start (if you do look in mails to find the sender address) :
The field you are looking for is : oMailItem.SenderEmailAddress
Sub Extract_Body_Subject_From_Mails()
Dim oNS As Outlook.NameSpace
Dim oFld As Outlook.Folder
Dim oMails As Outlook.Items
Dim oMailItem As Outlook.MailItem
Dim oProp As Outlook.PropertyPage
Dim sSubject As String
Dim sBody
'On Error GoTo Err_OL
Set oNS = Application.GetNamespace("MAPI")
Set oFld = oNS.GetDefaultFolder(olFolderInbox)
Set oMails = oFld.Items
For Each oMailItem In oMails
MsgBox oMailItem.SenderEmailAddress
'MsgBox oMails.Count 'oMails.Item(omails.Find(
sBody = oMailItem.Body
sSubject = oMailItem.Subject
'MsgBox sSubject
MsgBox sBody
Next
Exit Sub
Err_OL:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
Resume Next
End If
End Sub
'First create a rule that looks at the subject of incoming messages and fires when it sees "A new incident". Have the rule run a script. I called mine "Check_For_Ticket" in this example. See the pic of my rule attached.
Sub Check_For_Ticket(MyMail As MailItem)
On Error GoTo Proc_Error
Dim strTicket, strSubject As String
' Default value in case # is not found in the subject line
strTicket = "None"
' Grab the subject from the message
strSubject = MyMail.Subject
' See if it has a hash symbol in it
If InStr(1, strSubject, "#") > 0 Then
' Trim off leading stuff up to and including the hash symbol
strSubject = Mid(strSubject, InStr(strSubject, "#") + 1)
' Now find the trailing space after the ticket number and chop it off after that
If InStr(strSubject, " ") > 0 Then
strTicket = Left(strSubject, InStr(strSubject, " ") - 1)
End If
End If
MsgBox "Your Ticket # is: " & strTicket
Proc_Done:
Exit Sub
Proc_Error:
MsgBox "An error has occured in Check_For_Ticket. Error #" & Err & " - " & Err.Description
GoTo Proc_Done
End Sub
'Of course, you would substitute whatever processing you want where the messagebox shows the ticket number.
I changed some codes for getting selected messages attachments to my hard drive like below :
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim I As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim Counter As Long
strFolderpath = "D:\attachments"
If (Dir$(strFolderpath, vbDirectory) = "") Then
MsgBox "'" & strFolderpath & "' not exist"
MkDir strFolderpath
MsgBox "'" & strFolderpath & "' we create it"
Else
MsgBox "'" & strFolderpath & "' exist"
End If
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
strFolderpath = strFolderpath & "\"
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = strFolderpath
' Check each selected item for attachments.
Counter = 1
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For I = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(I).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & Counter & "_" & strFile
' Save the attachment as a file.
objAttachments.Item(I).SaveAsFile strFile
Counter = Counter + 1
Next I
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
MsgBox "All Selected Attachments Have Been Downloaded ..."
End Sub
my goal email uses imap service...
this vb codes works perfect!
but my problem is when download is finished we have not All needed files in attachments folder! (just some of them are there)
I have 450 UNREAD emails in my inbox that all of them have attachmen/s...
but we only have 200 files in attachments folder! (created by upper codes)
how can I fix this issue?
it seems this problem is in relationship with Unread Messages And My ADSL speed (but it should n't , I don't know?!)
when u read an email it seems Outlook does some stuff with that email and so next time that email runs faster because of it's caching.
how can I do this job for my unread emails with upper codes?
or is there any idea about this problem?
at last I would be really appreciate
for review and add or correct my codes
EDITION After comments :
my new code is like below :
Public Sub SaveAttachments()
Dim OlApp As Outlook.Application
Dim Inbox As MAPIFolder
Dim Item As Object
Dim ItemAttachments As Outlook.Attachments
Dim ItemAttachment As Object
Dim ItemAttCount As Long
Dim strFolderpath As String
Dim strFileName As String
Dim Counter As Long
Dim ItemsCount As Long
Dim ItemsAttachmentsCount As Long
strFolderpath = "d:\attachments"
If (Dir$(strFolderpath, vbDirectory) = "") Then
MsgBox "'" & strFolderpath & "' not exist"
MkDir strFolderpath
MsgBox "'" & strFolderpath & "' we create it"
Else
MsgBox "'" & strFolderpath & "' exist"
End If
' Get the path to your My Documents folder
'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
strFolderpath = strFolderpath & "\"
'On Error Resume Next
' Instantiate an Outlook Application object.
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.ActiveExplorer.CurrentFolder
Counter = 1
ItemsCount = 0
ItemsAttachmentsCount = 0
For Each Item In Inbox.Items
ItemsCount = ItemsCount + 1
For Each ItemAttachment In Item.Attachments
ItemsAttachmentsCount = ItemsAttachmentsCount + 1
' Get the file name.
strFileName = ItemAttachment.FileName
' Combine with the path to the Attachments folder.
strFileName = strFolderpath & Counter & "_" & strFileName
' Save the attachment as a file.
ItemAttachment.SaveAsFile strFileName
Counter = Counter + 1
Next ItemAttachment
Next Item
ExitSub:
Set ItemAttachment = Nothing
Set ItemAttachments = Nothing
Set Item = Nothing
Set Inbox = Nothing
Set OlApp = Nothing
MsgBox "All Selected Folder Attachments Have Been Downloaded ..."
MsgBox "ItemsCount : " & ItemsCount
MsgBox "ItemsAttachmentsCount : " & ItemsAttachmentsCount
End Sub
but the previous problem is still there
all of my emails in inbox(SELECTED FOLDER FOR UPPER CODE) are 455 (5 Read + 450 Unread)
MsgBox "ItemsCount : " & ItemsCount returns -> 455
MsgBox "Sum Of All ItemAttCount : " & ItemsAttachmentsCount returns 200 or a bit more
any idea?
A possible problem is that not all your messages are selected in the explorer. Your code requires the messages to be selected in the current Outlook explorer window.
Try printing the count of selected e-mails:
Set objSelection = Application.ActiveExplorer.Selection
Debug.Print objSelection.Count
If the result (visible in the debug window) is not 450, then not all your 450 messages are selected, and that's why some of them are ignored.
EDIT: According to your updated question, the code correctly finds all the e-mail messages, but only some of the attachments. This calls for some good old-fashioned debugging, beyond what can be answered on this website.
Try Debug.Print Item.Attachments.Count at the beginning of the For Each Item... loop. Is the attachment count sometimes zero? For which messages is it zero?
EDIT 2: You speculate that there is some kind of caching of attachment for opened mails. To test this (and to solve the problem if this is indeed the issue), you could open the mail items before saving the attachments (and then close the mail item when done). This can be done like this:
For Each Item In Inbox.Items
' Open the mail item
Item.Display
' Your code to save the attachments goes here.
' Close the mail item
Item.Close olDiscard
Next Item