I am trying to write a script that saves attachments to a directory. When I run it, I get an error message "type mismatch" and the line Set olAtt = olMi.Attachments is highlighted. Could someone advise?
Sub SaveAttachments()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim MyPath As String
Dim i As Long
Dim j As Long
Dim filesavename As String
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("Survey")
MyPath = "C:\Users\temp"
For i = (Fldr.Items.Count - 150) To Fldr.Items.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "Survey") > 0 Then
j = olMi.Attachments.Count
Set olAtt = olMi.Attachments
filesavename = MyPath & olAtt.Filename
olAtt.SaveAsFile filesavename
olMi.Save
olMi.Move MoveToFldr
End If
Next i
Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
olAtt is declared as a Outlook.Attachment (singular).
olMi.Attachments is a collection of attachments.
Related
I want to find an Outlook folder using folder.description value.
In folder.description I have more than one value. The code should take only one.
Private Sub CLemailbackupsaved_Click()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim objfolder As Outlook.MAPIFolder
Dim olItem As Object
Dim olMailItem As Outlook.MailItem
Dim intx As Long
'Dim reportid As String
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.Folders("a#a.com")
Set olFldr = olFldr.Folders("Inbox")
Debug.Print olFldr.Name
For intx = 1 To olFldr.Folders.Count
If olFldr.Folders.Item(intx).Description = "* MR090 *" Then
Set objfolder = olFldr.Folders.Item(intx)
Exit For
End If
Next
Debug.Print objfolder.Name
Set olNS = Nothing
Set objfolder = Nothing
Set olFldr = Nothing
Set olApp = Nothing
End Sub
Folder.description example value:
MR091 MR090
I created an Outlook rule to save an attachment then move it to the Deleted Items folder. The code works when I highlight the arrived email in the Inbox then move the email to the Deleted Items folder.
When the new email arrives, it is saving the attachment(s) from different email in the inbox and not moving the email to the Deleted Items folder.
The Outlook rule is:
Apply this rule after the message arrives
from Sender
and with Gift Card in the subject
and on this computer only
run Project1.SaveAttachments
Public Sub SaveAttachments(MItem As Outlook.Mailitem)
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 objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "Y:\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
strFile = strFolderpath & strFile
objAttachments.Item(i).SaveAsFile strFile
Next i
Set objNamespace = objOL.GetNamespace("MAPI")
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
objMsg.Move objDestFolder
End If
Next
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing
End Sub
According to my test, you could save email attachment and delete it using the below code:
Sub SaveAutoAttach()
Dim object_attachment As Outlook.attachment
Dim saveFolder As String
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String
Const olFolderInbox = 6
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")
If unRead.Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
some = ""
other = ""
saveFolder = "D:\"
For Each m In unRead
If m.Attachments.Count > 0 Then
For Each object_attachment In m.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".doc") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End If
m.Delete
Next m
End Sub
For more information, please refer to this link:
Auto Download Outlook Email Attachment – Code in VBA by Topbullets.com
I've been struggling with this for quite some time now, I don't get what I'm doing wrong.
I've got a script that will loop through emails in a folder. Then it checks the first 6 characters of the email subject. If it matches it must call a sub that will save the attachment to a specific folder, the only thing is that the file name changes every time depending on the subject of the email. Everything works fine if there is only 1 email in the folder, but as soon as there is more than 1 email it saves the last email attachment everytime but with the correct file name. So for example if you look at the underneath code it will save the attachment from ElseIf strLeft = "APPPE2" Then everytime with the filenames specified, eg report1.txt ... Help will be greatly appreciated.
Function LoopThroughFolder()
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Inbox").Folders("PPB")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Set Msg = Item
Dim strSubject As String
strSubject = Item.Subject
Dim strLeft As String
strLeft = Left(strSubject, 6)
If strLeft = "APP DA" Then
Call SaveAttachments1
ElseIf strLeft = "APPGR1" Then
Call SaveAttachments2
ElseIf strLeft = "APPPE2" Then
Call SaveAttachments3
End If
End If
Next
End Function
Public Sub SaveAttachments1()
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 strFile1 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "P:\database\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile1 = "report.txt"
MsgBox (strFile1)
strFile1 = strFolderpath & strFile1
MsgBox (strFile1)
objAttachments.Item(i).SaveAsFile strFile1
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments2()
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 strFile2 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "P:\database\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile2 = "report2.txt"
MsgBox (strFile2)
strFile2 = strFolderpath & strFile2
MsgBox (strFile2)
objAttachments.Item(i).SaveAsFile strFile2
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Public Sub SaveAttachments3()
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 strFile3 As String
Dim strFolderpath As String
Dim strDeletedFiles As String
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "P:\database\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile3 = "report3.txt"
strFile3 = strFolderpath & strFile3
objAttachments.Item(i).SaveAsFile strFile3
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Each of your SaveAttachments subs should have a objMsg parameter, which should be passed from LoopThroughFolder - there is no need to "re-find" the message just to save the attachments.
Untested but something like this:
Function LoopThroughFolder()
Dim objNS As Outlook.NameSpace, Item, Msg As Outlook.MailItem
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objFolder.Folders("Inbox").Folders("PPB")
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
' ... do stuff here ...
Set Msg = Item
Dim strSubject As String
strSubject = Msg.Subject
Dim strLeft As String
strLeft = Left(strSubject, 6)
If strLeft = "APP DA" Then
SaveAttachments1 Msg
ElseIf strLeft = "APPGR1" Then
SaveAttachments2 Msg
ElseIf strLeft = "APPPE2" Then
SaveAttachments3 Msg
End If
End If
Next
End Function
Public Sub SaveAttachments1(objMsg As Outlook.MailItem)
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFolderpath As String
strFolderpath = "P:\database\"
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
objAttachments.Item(i).SaveAsFile strFolderpath & "report.txt"
Next i
End If
End Sub
How do I select all Mails in the Deleted Items folder of a shared account (not my personal account) and then move them to a different folder not called "Deleted Items". For now, let's call the destination folder "Old Emails".
Here is what I have written so far:
'Macro for pseudo-archiving
Sub PseudoArchive()
On Error Resume Next
Dim objNamespace As Outlook.NameSpace
Dim sourceFolder As Outlook.MAPIFolder
Dim Messages As Selection
Dim Msg As MailItem
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("sharedemail#website.com")
Set sourceFolder = objFolder.Folders("Deleted Items")
'Define path to the target folder
Set destinationFolder = ns.Folders("sharedemail#website.com").Folders("Old Emails")
'Move emails in sourceFolder to destinationFolder
For Each Msg In sourceFolder
Msg.Move destinationFolder
Next
Set objNamespace = Nothing
Set sourceFolder = Nothing
Set Messages = Nothing
Set Msg = Nothing
End Sub
I am stuck on how to get the macro to select all items in the sourceFolder so it can then move them to the destinationFolder. I prefer not to manually select the emails in the folder before running the macro.
If anyone can provide assistance, that would be appreciated. Thanks!
You almost got it, try the following
Option Explicit
Sub PseudoArchive()
Dim objNamespace As Outlook.NameSpace
Dim sourceFolder As Outlook.MAPIFolder
Dim destinationFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim Msg As String
Dim i As Long
Set objNamespace = GetNamespace("MAPI")
Set sourceFolder = objNamespace.Folders("sharedemail#website.com").Folders("Deleted Items")
Set destinationFolder = objNamespace.Folders("sharedemail#website.com").Folders("Inbox").Folders("Old Emails")
Set Items = sourceFolder.Items
'Move emails in sourceFolder to destinationFolder
Msg = Items.Count & " Items in " & sourceFolder.Name & ", Move?"
If MsgBox(Msg, vbYesNo) = vbYes Then
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
Item.Move destinationFolder
Next
End If
End Sub
Here is a code snippet that should help.
Dim olApp As Outlook.Application
Dim olFol As Outlook.Folder, olDestFol As Outlook.Folder
Dim olItem As Object
Dim i as Long, j as Long
Set olApp = New Outlook.Application olApp.GetNamespace("MAPI").Folders("mailboxnamehere").Folders("Deleted Items")
Set olDestFol = olApp.GetNamespace("MAPI").Folders("mailboxnamehere").Folders("Inbox").Folders("Deleted Items") ' Destination Folder
Do Until olFol.Items.Count = 0
olFol.Items(1).Move olDestFolder
Loop
I'm using this script to export email from outlook. My question is how do I export the body of the email without the html formatting?
Sub SaveItemsToExcel()
On Error GoTo ErrorHandlerExit
Dim oNameSpace As Outlook.NameSpace
Dim oFolder As Outlook.MAPIFolder
Dim objFS As Scripting.FileSystemObject
Dim objOutputFile As Scripting.TextStream
Set objFS = New Scripting.FileSystemObject
Set objOutputFile = objFS.OpenTextFile("C:\Temp\Export.csv", ForWriting, True)
Set oNameSpace = Application.GetNamespace("MAPI")
Set oFolder = oNameSpace.PickFolder
If oFolder Is Nothing Then
GoTo ErrorHandlerExit
End If
If oFolder.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If
objOutputFile.WriteLine "From,Subject,Recived, Body"
ProcessFolderItems oFolder, objOutputFile
objOutputFile.Close
Set oFolder = Nothing
Set oNameSpace = Nothing
Set objOutputFile = Nothing
Set objFS = Nothing
ErrorHandlerExit:
Exit Sub
End Sub
Sub ProcessFolderItems(oParentFolder As Outlook.MAPIFolder, ByRef objOutputFile As Scripting.TextStream)
Dim oCount As Integer
Dim oMail As Outlook.MailItem
Dim oFolder As Outlook.MAPIFolder
oCount = oParentFolder.Items.Count
For Each oMail In oParentFolder.Items
If oMail.Class = olMail Then
objOutputFile.WriteLine oMail.SenderEmailAddress & "," & Replace(oMail.Subject, ",", "") & "," & oMail.ReceivedTime
End If
Next oMail
Set oMail = Nothing
If (oParentFolder.Folders.Count > 0) Then
For Each oFolder In oParentFolder.Folders
ProcessFolderItems oFolder, objOutputFile
Next
End If
End Sub
Try setting BodyFormat to olFormatPlain before reading Body property.