Not all mail items are saved when using subject as file name - vba

I obtained the code from a tutorial online.
I tested it and updated variables specific to my local system.
There is a problem with the export.
Previously, I ran the code successfully.
All 128 items of the Outlook folder were obtained.
There are now 231 items in the Outlook folder.
The code repeatedly only obtains 162.
I can confirm;
all items are mail (not meeting or read receipts)
the 162 items obtained contains attachments - so it is not a limit on this basis
I refreshed and sync'd Outlook exchange with local machine several times.
previously, one mail item contained *** in the title. This broke the code, I adapted it as can be seen, and it ran without issue.
I considered
mail items are of a type that I have not defined?
there is an issue with the titles of the other mail items?
this code is limited by memory allocation?
the problem is the sync between Outlook exchange and local device
Sub ZipAllEmailsInAFolder()
Dim objFolder As Outlook.Folder
Dim objItem As Object
Dim objMail As Outlook.MailItem
Dim strSubject As String
Dim varTempFolder As Variant
Dim varZipFile As Variant
Dim objShell As Object
Dim objFileSystem As Object
'Select an Outlook Folder
Set objFolder = Outlook.Application.Session.PickFolder
If Not (objFolder Is Nothing) Then
'Create a temp folder
varTempFolder = "C:\Users\thomdenm\Music\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS")
MkDir (varTempFolder)
varTempFolder = varTempFolder & "\"
'Save each email as msg file
For Each objItem In objFolder.Items
If TypeOf objItem Is MailItem Then
Set objMail = objItem
strSubject = objMail.Subject
strSubject = Replace(strSubject, "/", " ")
strSubject = Replace(strSubject, "\", " ")
strSubject = Replace(strSubject, ":", "")
strSubject = Replace(strSubject, "?", " ")
strSubject = Replace(strSubject, Chr(34), " ")
strSubject = Replace(strSubject, "*", " ")
objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG
End If
Next
'Create a new ZIP file
varZipFile = "C:\Users\thomdenm\Music\" & objFolder.Name & " Emails.zip"
Open varZipFile For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'Add the exported msg files to the ZIP file
Set objShell = CreateObject("Shell.Application")
objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items
On Error Resume Next
Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temp folder
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1)
End If
End Sub

First of all, I'd remove the condition where you check for the item type or add others to make sure all items are processed. Or just add a counter to see how much items were checked through.
counter = counter+1
If TypeOf objItem Is MailItem Then
Second, the On Error statement can help you identify the source of the problem if any error comes in.
Third, it makes sense to split the logic where you get Outlook items and save them to a folder. The other piece of code can be extracted to a separate method , so following this way you can easily be sure that one or another method works correctly (the Outlook-related part).
And, finally, the most important thing is that items can belong to the same conversation and have identical subject line which can lead to overwriting saved items in the folder. Is this the case?
objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG
I'd recommend adding any ID to the file name so you can be sure no items are overwritten in the folder. For example, it can be current time or milliseconds and etc.

Related

VB.net - Read .msg file from the shared folder and extract the attachments inside it

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.

Error saving attachments when they are embedded

I'm saving Outlook attachments (as part of a copy).
I get an error message from the line objAtt.SaveAsFile strFile when the attachment is an embedded image.
The code (gratefully copied!) is:
Sub CopyAttachments(objSourceItem, objTargetItem)
Dim objAtt As Outlook.Attachment
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , 1, objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
The full error message is:
I don't need embedded images, so skipping them would work too.
Is that an RTF message? RTF messages embed images and objects (such as Excel spreadsheets) not as files, but as OLE objects, and Attachment.SaveAsFile will fail for the OLE attachments. If you want to filter out attachments like that, make sure you either skip attachments with the Attachment.Type = olOLE (6) or only deal with the attachments of type olByValue or olEmbeddeditem.
If you still need to save OLE attachments, you can use Redemption (I am its author) - its RDOAttachment.SaveAsFile method will extract the file data from most common OLE attachments (such Word docs, PDF files, Excel spreadsheets, images, etc.)
First of all, make sure the file path is fully qualified, i.e. you end up with a valid string here:
strFile = strPath & objAtt.FileName
Second, when you call the Attachments.Add make sure the file exists on the disk. The source of the attachment can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment.
You may try to run the following code which saves an attachment on the disk:
Sub SaveAttachment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the first attachment " & _
"in the current item to the Documents folder? If a file with the " & _
"same name already exists in the destination folder, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _
myAttachments.Item(1).DisplayName
End If
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub

Save attachments to a folder in outlook and rename them

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!

Visual basic script not working on Outlook 2010 rule

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?

macro to download selected messages attachments - Problem about downloaded files count

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