I am new to VBA. I have prepared one code to download multiple emails' attachments for current date only but whenever I execute this macro, it's giving me:
Automation Error, The system cannot find the specified path
Can someone look into below pasted code and help me out. Thanks
Sub Outlook_Attachments()
Dim OLOOK As Outlook.Application
Dim OMAIL As Outlook.MailItem
Dim ONS As Outlook.Namespace
Dim FOL As Outlook.Folder
Dim SFOLDER As String
Dim FNAME As String
Set OLOOK = New Outlook.Application
Set OMAIL = OLOOK.CreateItem(olMailItem)
Set ONS = OLOOK.GetNamespace("MAPI")
Set FOL = ONS.GetDefaultFolder(olFolderInbox).Folders("Test")
SFOLDER = "D:\"
FNAME = SFOLDER & Format(Date, "MM/DD/YYYY") & "*"
For Each OMAIL In FOL.Items
For Each ATMT In OMAIL.Attachments
ATMT.SaveAsFile FNAME & ATMT.DisplayName
Next
Next
End Sub
Try this:
Sub Outlook_Attachments()
Dim OLOOK As Outlook.Application
Dim OMAIL As Outlook.MailItem
Dim ONS As Outlook.Namespace
Dim FOL As Outlook.Folder
Dim SFOLDER As String
Dim FNAME As String
Set OLOOK = New Outlook.Application
Set OMAIL = OLOOK.CreateItem(olMailItem)
Set ONS = OLOOK.GetNamespace("MAPI")
Set FOL = ONS.GetDefaultFolder(olFolderInbox).Folders("Test")
SFOLDER = "D:\"
FNAME = SFOLDER & Format(Date, "MM-DD-YYYY") & "-"
For Each OMAIL In FOL.Items
'check email recevied date
If Format(OMAIL.ReceivedTime, "MM-DD-YYYY") = Format(Date, "MM-DD-YYYY") Then
For Each ATMT In OMAIL.Attachments
ATMT.SaveAsFile FNAME & ATMT.DisplayName
Next
End If
Next
End Sub
Using '/' and '*' in file/folder name is forbidden.
Related
The following code does everything I want: pulls email, saves attachments, extracts files
EXCEPT save the original email to the folder fDest. I seem unable to see the solution.
This seems to be the problematic line as it won't save the email:
"mi.SaveAs fDest2, olMSG"
Sub SaveAttachments()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim Inbox As MAPIFolder
Dim strDate As String
Dim oApp As Object
Dim fDest As Variant
Dim j As Variant
Dim sh As String
Dim FileDialog As FileDialog
Dim Tracker As Workbook
Dim fSheet As Sheets
Dim LastRow As Long
Dim strFilePath
Dim fTracker As Workbook
strDate = InputBox("Enter Date in format dd-Mmm-yyyy", "User Date", Format(Now(), "dd-Mmm-yyyy"))
strFilePath = "\\namdfs\CARDS\MWD\GROUPS\GCM_NAM\2021\05 May\"
fTrackerName = "Inquiry.Tracker.SWPA.Violations.May.2021.xlsx" '
On Error Resume Next
Set fTracker = Workbooks(fTrackerName)
'If Err Then Set fTracker = Workbooks.Open(strFilePath & fTrackerName)
On Error GoTo 0
'Windows(fTrackerName).Activate
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.Folders("GCMNamLogs").Folders("Inbox")
fDest = "C:\Users\jb76991\Desktop\Violations_Emails\"
fUser = UCase(Environ("username")) & ":" & Chr(10) & Now()
For Each i In fol.Items.Restrict("#SQL=urn:schemas:httpmail:subject LIKE '%" & strDate & "%'")
'Debug.Print fDest & i & ".msg"
If i.Class = olMail Then
Set mi = i
fDest2 = fDest & mi.Subject & ".msg"
mi.SaveAs fDest2, olMSG
For Each at In mi.Attachments
'do something with attachments but i've commented it out
Next at
End If
Next i
MsgBox ("Completed")
End Sub
Can anyone tell me how to save the original emails that are being filtered?
You must be sure there are no invalid characters in the filename. See What characters are forbidden in Windows and Linux directory names? for more information. So, I'd suggest using the Replace method available in VBA before passing anything to the SaveAs method.
Another point is that you need to specify unique file names to each email. Make sure the generated file name is unique for a folder.
Its works frist time when i am login to the system but for testing second time if i am going to run this code again it will gives me type mismatch error. can somebody help me on this.
Sub Saveattachment()
Application.DisplayAlerts = False
Dim ATMT As Outlook.Attachment
Dim OMAIL As Outlook.MailItem
Dim FOL As Outlook.Folder
Dim ONS As Outlook.Namespace
Dim OLOOK As Outlook.Application
Dim var As Date
Dim count As Long
count = 0
Dim name As String
Dim temp As Variant
Set OLOOK = New Outlook.Application
Set ONS = Outlook.GetNamespace("MAPI")
Set FOL = ONS.Folders("IM_DMBI").Folders("inbox")
Set OMAIL = OLOOK.CreateItem(olMailItem)
msgbox "Please remove old downloads, If already remove please ingore and press Ok to proceed", vbInformation
For Each OMAIL In FOL.items
For Each ATMAT In OMAIL.Attachments
var = Format(OMAIL.ReceivedTime, "MM/DD/YY")
name = Left(OMAIL.Subject, 3)
If name = "304" And var = Date And Err.Number = 13 Then
count = count + 1
ATMAT.SaveAsFile Sheet1.Cells(1, 1) & Application.PathSeparator & ATMAT.filename
End If
If var < Date Then
msgbox "Totlay:-" & count & " Files downloaded for today", vbInformation
Exit Sub
End If
Next
Next
Application.DisplayAlerts = True
End Sub
Screenshot of the error: https://i.stack.imgur.com/5dKPy.png
This helps you to ignore type mismatch error:
Sub GetAttachment()
Application.DisplayAlerts = False
Dim ATMT As Outlook.Attachment
Dim OMAIL As Outlook.MailItem
Dim FOL As Outlook.Folder
Dim ONS As Outlook.Namespace
Dim OLOOK As Outlook.Application
Dim var As Date
Dim count As Long
count = 0
Dim name As String
Dim temp As Variant
Set OLOOK = New Outlook.Application
Set ONS = Outlook.GetNamespace("MAPI")
Set FOL = ONS.Folders("IM_DMBI").Folders("inbox")
Set OMAIL = OLOOK.CreateItem(olMailItem)
'msgbox "Please remove old downloads, If already remove please ingore and press Ok to proceed", vbInformation
For Each OMAIL In FOL.items
On Error GoTo errorHandler
For Each ATMAT In OMAIL.Attachments
var = Format(OMAIL.ReceivedTime, "MM/DD/YY")
name = Left(OMAIL.Subject, 5)
If name = "304 r" And var = Date Then
count = count + 1
ATMAT.SaveAsFile Sheet1.Cells(1, 1) & Application.PathSeparator & ATMAT.filename
End If
If var < Date Then
'msgbox "Totlay:-" & count & " Files downloaded for today", vbInformation
Exit Sub
End If
Next
TypeMismatch:
Next
errorHandler:
If Err = 13 Then 'Type Mismatch
Resume TypeMismatch
End If
Application.DisplayAlerts = True
End Sub
There can be items other than mailitems in the inbox.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Saveattachment()
Application.DisplayAlerts = False
'Dim ATMT As outlook.Attachment
Dim ATMAT As outlook.Attachment
Dim oObjItem As Object 'Any type, there can never be a mismatch
Dim OMAIL As outlook.MailItem
Dim FOL As outlook.folder
Dim ONS As outlook.namespace
Dim OLOOK As outlook.Application
Dim var As Date
Dim count As Long
count = 0
Dim name As String
Dim temp As Variant
Set OLOOK = New outlook.Application
'Set ONS = outlook.GetNamespace("MAPI")
Set ONS = OLOOK.GetNamespace("MAPI")
Set FOL = ONS.folders("IM_DMBI").folders("inbox")
'Set OMAIL = OLOOK.CreateItem(olMailItem)
For Each oObjItem In FOL.Items ' any type of item
'For Each OMAIL In FOL.Items
' One of at least three ways to verify
If TypeName(oObjItem) = "MailItem" Then
' Now that you have a mailitem
Set OMAIL = oObjItem
For Each ATMAT In OMAIL.Attachments
Debug.Print "Attachment found."
Next
Else
Debug.Print "This would have been a type mismatch."
End If
Next
Application.DisplayAlerts = True
End Sub
I am trying to create a Macro that can efficiently search a Shared Mailbox in outlook with my desired category and date the email was received.
txtCat will be the category
txtDate is where I will input the date in this format : "mm/dd/yyyy"
Private Sub CommandButton1_Click()
Dim outlookapp
Dim olns As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Object
Dim myTasks
Dim myrecipient As Outlook.Recipient
Dim dateString As Long
Dim strfilter As String
Set outlookapp = CreateObject("Outlook.Application")
Set olns = outlookapp.GetNamespace("MAPI")
Set myrecipient = olns.CreateRecipient("Cmaintenancesupport2")
myrecipient.Resolve
Dim strCat As String
'txtCat is the category
'txtDate is the date
Set Fldr = olns.GetSharedDefaultFolder(myrecipient, olFolderInbox)
strCat = UserForm1.txtCat.Text
strfilter = "[Categories] = """ & strCat & """"
dateString = CDate(UserForm1.txtDate.Text)
Set myTasks = Fldr.Items.Restrict(strfilter) 'filters the desired category in the SharedDefault Mailbox
Set myTasks = myTasks.Restrict("[ReceivedTime] = '" & Format(dateString, "DDDDD HH:NN") & "'") 'adds another filter by date
For Each olMail In myTasks
olMail.Display
Next
End Sub
i set mytasks twice as I am just restructuring this code from a previous project that works (categorized email > filter by days > search subject line) but somehow it is not showing me any results.
What should happen here is after the category filter, it should all already categorized email with the desired date.
I am trying to run a code where I copy content from mail body that may have some hyperlinks. I would like to retain hyperlinks while creating the word document
I tried various methods like Selection.AutoFormat = True but none worked
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim olItems As Outlook.Items
Dim i As Integer
Dim savePath As String
Dim filePath As String
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
Set olItems = Folder.Items
filePath = ActiveWorkbook.Path
For Each OutlookMail In olItems
If OutlookMail.ReceivedTime >= Date - 1 Then
Dim objWord
Dim objDoc
Dim objSelection
Dim text As String
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = False
Set objSelection = objWord.Selection
text = OutlookMail.Body
startPos = InStr(1, text, "Market Briefs")
endPos = InStr(startPos, text, "http")
text = Replace(Mid(text, startPos, endPos - startPos), " ", "-")
Set oPara1 = objDoc.Content.Paragraphs.Add
oPara1.Range.text = text
oPara1.Range.Font.Bold = True
oPara1.Format.SpaceAfter = 0
savePath = filePath & "\" & Format(Now(), "yyyy-mm-dd")
With objDoc.Styles("Normal").ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
End With
If Len(Dir(savePath, vbDirectory)) = 0 Then
MkDir savePath
End If
objDoc.SaveAs (savePath & "\ABC.docx")
objDoc.Close
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
Work with Copy & PasteAndFormat Method when coping email body
Quick Example would be
Option Explicit
Public Sub Example()
Dim OutlookMail As Variant
For Each OutlookMail In ActiveExplorer.Selection
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Set wdDoc = wdApp.Documents.Add
OutlookMail.GetInspector().WordEditor.Range.Copy
Dim oPara1 As Word.Paragraph
Set oPara1 = wdDoc.Content.Paragraphs.Add
oPara1.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
Next
End Sub
Remember to set Outlook & Word library References, Tools -> References
Use Word's Document.Hyperlinks.Add method against the Range object containing the text to add a URL. See: https://learn.microsoft.com/en-us/office/vba/api/word.hyperlinks.add
I am trying to save all the emails, resulting out of instant text search into the hard drive folder. the below code is able to perform the search but giving me an error at selectallitems line while selecting each mail and saving them in HD. code is in excel vba;
Dim OlApp As Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Dim fldrpath As String
fldrpath = "\\mydata\EMAILS\
Check subfolder for messages and exit of none found
txtsearch = "abc#xyz.com, received:4/1/2017..4/30/2017"
OlApp.ActiveExplorer.Search txtsearch, olSearchScopeAllFolders
Dim myitem As Outlook.MailItem
Dim objitem As Object
Set myitem = OlApp.ActiveExplorer.SelectAllItems
Set objitem = myitem
objitem.SaveAs fldrpath & "test" & ".msg", olMSG
Any other alternative code to get the emails saved will also be appreciated.
Thanks in advance !! looking for a quick solution
Saving search results appears to be more easily achieved a different way.
From Outlook, not Excel.
Sub SearchForStr_Save()
Dim strSearch As String
Dim strDASLFilter As String
Dim strScope As String
Dim objItem As Object
Dim objSearch As search
Dim srchFolder As folder
Dim fldrpath As String
strSearch = "abc#xyz.com"
strDASLFilter = "urn:schemas:httpmail:textdescription LIKE '%" & strSearch & "%'"
strScope = "'Inbox'"
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strDASLFilter, SearchSubFolders:=True, Tag:="SearchFolder")
Set srchFolder = objSearch.Save(strSearch)
'fldrpath = "\\mydata\EMAILS\"
fldrpath = "h:\test\"
For Each objItem In srchFolder.Items
'Debug.Print objItem.subject
If objItem.Class = olMail Then
objItem.SaveAs fldrpath & "test" & ".msg", olMsg
End If
Next
ExitRoutine:
Set objSearch = Nothing
Set srchFolder = Nothing
End Sub