We are using a VBA macro in Excel to count mails in several Outlook subfolders.
I'd also like to use it to count mails in searchfolders, but it isn't working.
The code loops through different Outlook folders, the location of each of this folders is available in a column in an Excel sheet. (mailbox#mail.com\folder\subfolder - with different possibilities of mailboxes / folders).
We refer to this folder with the following code:
set mailfolder = GetFolder(email_folder)
This is the GetFolder function:
Function GetFolder(ByVal strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error Resume Next
'strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
On Error GoTo 0
End Function
Is there a way to adapt this function to find the searchfolders?
Use the folder name. No path.
Private Sub Test_Unread()
FindSearchFolder "Unread Mail"
End Sub
Private Sub FindSearchFolder(fldrName As String)
Debug.Print
Debug.Print "Searching for " & fldrName
Dim objStores As Stores
Dim objStore As Store
Dim objSearchFolders As folders
Dim objSearchFolder As folder
Dim objItem As Object
Dim bFound As Boolean
Dim i As Long
Set objStores = Session.Stores
For Each objStore In objStores
Debug.Print
Debug.Print "objStore: " & objStore
bFound = False
Set objSearchFolders = objStore.GetSearchFolders
For Each objSearchFolder In objSearchFolders
Debug.Print " objSearchFolder: " & objSearchFolder
If objSearchFolder.name = fldrName Then
Debug.Print " Found in " & objStore
bFound = True
Set ActiveExplorer.CurrentFolder = objSearchFolder
Debug.Print objSearchFolder.Items.count
End If
If bFound = True Then Exit For
Next
If bFound = False Then Debug.Print " Not found in " & objStore
Next
End Sub
If you find an error that is unfixable/unexplainable, when testing/manipulating searchfolders, close Outlook and restart.
Related
I'm trying to save the Outlook attachment from a particular sub folder to a local path.
I'm able to save the file as is to the local path.
The requirement is to save the xl attachment using a cell value of ThisWorkbook as the file name.
Sub ManualPunchAttachmentsExtract()
Dim OlFolder As Outlook.MAPIFolder
Dim OlMail As Object
Dim OlApp As Outlook.Application
Dim OlItems As Outlook.Items
Dim Get_namespace As Outlook.Namespace
Dim strFolder As String
Dim i As Integer
ThisWorkbook.Activate
Sheets("MP File Save").Activate
Range("H3").Activate
Set OlApp = GetObject(, "Outlook.Application")
If err.Number = 429 Then
Set OlApp = CreateObject("Outlook.Application")
End If
strFolder = InputBox("Please Enter the Folder Path alongwith ' \ ' at the end", Path)
'Set Get_namespace = OlApp.GetNamespace("MAPI")
Set OlFolder = OlApp.GetNamespace("MAPI").Folders("shaikajaz.k#flex.com").Folders("Archive").Folders("Juarez").Folders("Manual Punch")
Set OlItems = OlFolder.Items
'.Restrict("[Unread]=true")
For Each OlMail In OlItems
If OlMail.UnRead = False Then
Else
ThisWorkbook.Activate
Sheets("MP File Save").Activate
ActiveCell.Value = OlMail.Subject
ActiveCell.Offset(0, 1).Value = OlMail.ReceivedTime
If OlMail.attachments.Count > 0 Then
For i = 1 To OlMail.attachments.Count
OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & OlMail.attachments.Item(i).FileName
OlMail.UnRead = False
ThisWorkbook.Activate
ActiveCell.Offset(1, 0).Select
Next i
Else
End If
End If
Next
MsgBox ("Done")
End Sub
First of all, iterating over all items in an Outlook folder is not realy a good idea. Use the Find/FindNext or Restrict methods of the Items class instead. So, instead of the following code:
For Each OlMail In OlItems
If OlMail.UnRead = False Then
Use this:
Private Sub FindAllUnreadEmails(folder As Outlook.MAPIFolder)
Dim searchCriteria As String = "[UnRead] = true"
Dim counter As Integer = 0
Dim mail As Outlook._MailItem = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItem As Object = Nothing
If (folder.UnReadItemCount > 0) Then
folderItems = folder.Items
resultItem = folderItems.Find(searchCriteria)
While Not IsNothing(resultItem)
If (TypeOf (resultItem) Is Outlook._MailItem) Then
counter += 1
mail = resultItem
Debug.Print("#" + counter.ToString() + _
" - Subject: " + mail.Subject)
End If
resultItem = folderItems.FindNext()
End While
Else
Debug.Print("There is no match in the " + _
folder.Name + " folder.")
End If
End Sub
Note, attached files can have the same file name. So, to uniquelly identify files I'd suggest introducing any IDs in the file name when attachments are saved to the disk.
Finally, to save the attached file with a workbook's content name you need to pass a cell value to the SaveAsFile method:
OlMail.attachments.Item(i).SaveAsFile strFolder & "\" & yourWorksheet.Range("B2").Value
I want to select where to save the PDFs instead of saving them to the folder where the excel files live.
I also want to only print the first worksheet.
The Dims ending with a 2 is what I added to try and make this work. I get both pop ups to appear but after I select where I want to save the PDFs then it fails at Set objFolder2 = objFileSystem2.GetFolder(strPath2)
Any help is much appreciated.
Sub ExcelPlot()
Dim objShell As Object
Dim objWindowsFolder As Object
Dim objWindowsFolder2 As Object
Dim strWindowsFolder As String
'Select the specific Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Locate the Excel files", 0, "")
'Select where to save to
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder2 = objShell.BrowseForFolder(0, "Where would you like to save the PDFs?", 0, "")
If Not objWindowsFolder Is Nothing Then
strWindowsFolder = objWindowsFolder.self.Path & "\"
Call ProcessFolders(strWindowsFolder)
'Open the windows folder
Shell "Explorer.exe" & " " & strWindowsFolder, vbNormalFocus
End If
End Sub
Sub ProcessFolders(strPath As String)
Dim strPath2 As String
Dim objFileSystem As Object
Dim objFileSystem2 As Object
Dim objFolder As Object
Dim objFolder2 As Object
Dim objFile As Object
Dim objExcelFile As Object
Dim objWorkbook As Excel.Workbook
Dim strWorkbookName As String
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strPath)
Set objFolder2 = objFileSystem2.GetFolder(strPath2)
For Each objFile In objFolder.Files
strFileExtension = objFileSystem.GetExtensionName(objFile)
If LCase(strFileExtension) = "xls" Or LCase(strFileExtension) = "xlsx" Then
Set objExcelFile = objFile
Set objWorkbook = Application.Workbooks.Open(objExcelFile.Path)
strWorkbookName = Left(objWorkbook.Name, (Len(objWorkbook.Name) - Len(strFileExtension)) - 1)
objWorkbook.ExportAsFixedFormat Type:=xlTypePDF, fileName:=strPath2 & strWorkbookName & ".pdf"
objWorkbook.Close False
End If
Next
'Process all folders and subfolders
If objFolder.SubFolders.Count > 0 Then
For Each objSubFolder In objFolder.SubFolders
If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
ProcessFolders (objSubFolder.Path)
End If
Next
End If
End Sub
Thanks
You can do something like this - you need to pass both of the paths to ProcessFolders
Sub ExcelPlot()
Dim sourceFolder As String, destFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Locate the Excel files"
If .Show = -1 Then
sourceFolder = .SelectedItems(1)
.Title = "Where would you like to save the PDFs?"
If .Show = -1 Then
destFolder = .SelectedItems(1)
ProcessFolders sourceFolder, destFolder
Shell "Explorer.exe" & " " & destFolder, vbNormalFocus
End If
End If
End With
End Sub
EDIT: Here's an updated (non-recursive) version of your folder processing sub:
Sub ProcessFolders(sourceFolder As String, destFolder As String)
Dim objFileSystem As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim objFile As Object
Dim objWorkbook As Excel.Workbook
Dim strWorkbookName As String, strFileExtension As String
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim colFolders As New Collection
colFolders.Add sourceFolder
Do While colFolders.Count > 0
Set objFolder = objFileSystem.GetFolder(colFolders(1)) 'get the first path
colFolders.Remove 1 'remove from listing
'Process files in this folder
For Each objFile In objFolder.Files
strFileExtension = objFileSystem.GetExtensionName(objFile)
If LCase(strFileExtension) = "xls" Or LCase(strFileExtension) = "xlsx" Then
Set objWorkbook = Application.Workbooks.Open(objFile.Path)
strWorkbookName = Left(objWorkbook.Name, _
(Len(objWorkbook.Name) - Len(strFileExtension)) - 1)
objWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=objFileSystem.buildpath(destFolder, strWorkbookName & ".pdf")
objWorkbook.Close False
End If
Next
'Process subfolders
For Each objSubFolder In objFolder.SubFolders
If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
colFolders.Add objSubFolder.Path 'add this to the collection for processing
End If
Next
Loop
End Sub
I am trying to open msg (Outlook item) files saved in my desktop folder (C:\Desktop\Index) and search for attachments (single/zip file).
I am getting
'object doesn't support this property or method' error for:
Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
Option Explicit
Sub GetMSG()
*True includes sub folders
*False to check only listed folder
ListFilesInFolder "C:\Desktop\Index\", True
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile, strFileType, strAttach As String
Dim openMsg As MailItem
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFolderpath As String
'where to save attachments
strFolderpath = "C:\Desktop\Index\Attachments\"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
' This code looks at the last 4 characters in a filename
' If we wanted more than .msg, we'd use Case Select statement
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
openMsg.Display
'do whatever
Set objAttachments = openMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' Get the file name.
strAttach = objAttachments.Item(i).Filename
' Combine with the path to the Temp folder.
strAttach = strFolderpath & strAttach
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strAttach
Next i
End If
openMsg.Close olDiscard
Set objAttachments = Nothing
Set openMsg = Nothing
' end do whatever
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Write this before the error:
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate(FileItem.Path)
When you are using Application, it refers to the Excel application and not to the Outlook application. And the Excel Application does not support CreateItemFromTemplate.
You can also use early binding:
Dim OutApp As New Outlook.Application
Set OutMail = OutApp.CreateItemFromTemplate(FileItem.Path)
Currently my code listed below will copy body information from an incoming email and open the designated excel sheet and copy the contents onto the excel sheet and close it. I would also like to save attachments from incoming email to this designated path :C:\Users\ltorres\Desktop\Projects
I have tried this, but this code will not incorporate with outlook. I would have to run it with excel
Public Sub saveAttachtoDisk (itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat As String
saveFolder = "C:\Users\ltorres\Desktop\Projects"
dateFormat = Format(Now, "yyyy-mm-dd H-mm")
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
Const xlUp As Long = -4162
Sub ExportToExcel(MyMail As MailItem)
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Show Excel
oXLApp.Visible = True
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\ltorres\Desktop\Projects\Project 2\TemplateFinal\lighting.xlsm")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Multiplier")
lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1
'~~> Write to outlook
With oXLws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
Dim MyAr() As String
MyAr = Split(olMail.Body, vbCrLf)
For i = LBound(MyAr) To UBound(MyAr)
.Range("A" & lRow).Value = MyAr(i)
lRow = lRow + 1
Next i
'
End With
'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub
To add to #Om3r response, you could add this code (untested) to the ThisOutlookSession module:
Private WithEvents objNewMailItems As Outlook.Items
Dim WithEvents TargetFolderItems As Items
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
'Update to the correct Outlook folder.
Set TargetFolderItems = ns.Folders.item("Mailbox - Luis") _
.Folders.item("Inbox") _
.Folders.item("Lighting Emails").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal item As Object)
SaveAtmt_ExportToExcel item
End Sub
This will watch the Lighting Emails folder (or whatever folder you choose) and execute the SaveAtmt_ExportToExcel procedure whenever an email arrives in that folder.
This will mean that Excel will open and close for each email. It will also interrupt whatever else you're doing to open Excel and execute - so will probably want to update so it only opens Excel once and to run the Outlook rule to place the emails in the correct folder once a day rather than always on.
Try it this way...
Update SaveFolder = "c:\temp\" and Workbooks.Open("C:\Temp\Book1.xlsx")
Tested on Outlook 2010
Public Sub SaveAtmt_ExportToExcel(Item As Outlook.MailItem)
Dim Atmt As Outlook.Attachment
Dim SaveFolder As String
Dim DateFormat As String
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
Dim i As Long
SaveFolder = "c:\temp\"
DateFormat = Format(Now, "yyyy-mm-dd H mm")
For Each Atmt In Item.Attachments
Atmt.SaveAsFile SaveFolder & "\" & DateFormat & " " & Atmt.DisplayName
Next
strID = Item.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
'~~> Show Excel
oXLApp.Visible = True
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("C:\Temp\Book1.xlsx")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("Multiplier")
lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1
'~~> Write to outlook
With oXLws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
Dim MyAr() As String
MyAr = Split(olMail.body, vbCrLf)
For i = LBound(MyAr) To UBound(MyAr)
.Range("A" & lRow).Value = MyAr(i)
lRow = lRow + 1
Next i
'
End With
'~~> Close and Clean
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
Set Atmt = Nothing
End Sub
I'm trying to open .msg files from a specified directory using VBA but I keep getting a runtime error.
The code i have:
Sub bla()
Dim objOL As Object
Dim Msg As Object
Set objOL = CreateObject("Outlook.Application")
inPath = "C:\Users\SiliconPlus\Desktop\Si+ Contact Lists\Contact_Si+"
thisFile = Dir(inPath & "\*.msg")
Set Msg = objOL.CreateItemFromTemplate(thisFile)
' now use msg to get at the email parts
MsgBox Msg.Subject
Set objOL = Nothing
Set Msg = Nothing
End Sub
Here is the runtime error:
Run-time error '-2147287038 (80030002)':
Cannot open file: AUTO Andy Low Yong Cheng is out of the office (returning 22 09 2014).msg.
The file may not exist, you may not have permission to open it, or it may be open in another program. Right-click the folder that contains the file, and then click properties to check your permissions for the folder.
Kenneth Li You didn't had the full path when opening the file. Try this:
Sub bla_OK()
Dim objOL As Object
Dim Msg As Object
Set objOL = CreateObject("Outlook.Application")
inPath = "C:\Users\SiliconPlus\Desktop\Si+ Contact Lists\Contact_Si+"
thisFile = Dir(inPath & "\*.msg")
'Set Msg = objOL.CreateItemFromTemplate(thisFile)
Set Msg = objOL.Session.OpenSharedItem(inPath & "\" & thisFile)
' now use msg to get at the email parts
MsgBox Msg.Subject
Set objOL = Nothing
Set Msg = Nothing
End Sub
If you get an error, try the Late Biding (Dim Msg As Object) right under the MsgBox (need to be uncommented) :
Sub Kenneth_Li()
Dim objOL As Outlook.Application
Dim Msg As Outlook.MailItem
Msgbox "If you get an error, try the Late Biding right under this (need to be uncommented)"
'Dim objOL As Object
'Dim Msg As Object
Set objOL = CreateObject("Outlook.Application")
inPath = "C:\Users\SiliconPlus\Desktop\Si+ Contact Lists\Contact_Si+"
thisFile = LCase(Dir(inPath & "\*.msg"))
Do While thisFile <> ""
'Set Msg = objOL.CreateItemFromTemplate(thisFile)
'Or
'Set Msg = objOL.OpenSharedItem(thisFile)
'Set Msg = GetNameSpace("MAPI").OpenSharedItem(thisFile)
'Eventually with Shell command (here for notepad)
'Shell "notepad " & thisFile
Set Msg = objOL.Session.OpenSharedItem(thisFile)
Msg.display
MsgBox Msg.Subject
thisFile = Dir
Loop
Set objOL = Nothing
Set Msg = Nothing
End Sub
Or you can find a nice VB solution there : http://www.mrexcel.com/forum/excel-questions/551148-open-msg-file-using-visual-basic-applications.html#post2721847
And here for more details on Shell method : http://p2p.wrox.com/access-vba/27776-how-open-msg-file-vbulletin.html#post138411
Another way is to run the file programmatically (in VBA use the Shell command). It will be opened in Outlook where you can get an active inspector window with the item opened.
You should check follow code and can modify your code
Sub CreateFromTemplate()
Dim MyItem As Outlook.MailItem
Set MyItem = Application.CreateItemFromTemplate("C:\temp\*.msg")
MyItem.Display
End Sub
Try this
Sub GetMSG()
' True includes subfolders
' False to check only listed folder
ListFilesInFolder "C:\Users\lengkgan\Desktop\Testing", True
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile, strFileType, strAttach As String
Dim openMsg As MailItem
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFolderpath As String
'where to save attachments
strFolderpath = "C:\Users\lengkgan\Desktop\Testing"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
' This code looks at the last 4 characters in a filename
' If we wanted more than .msg, we'd use Case Select statement
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set openMsg = Outlook.Application.CreateItemFromTemplate(FileItem.Path)
openMsg.Display
'do whatever
Set objAttachments = openMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' Get the file name.
strAttach = objAttachments.Item(i).Filename
' Combine with the path to the Temp folder.
strAttach = strFolderpath & strAttach
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strAttach
Next i
End If
openMsg.Close olDiscard
Set objAttachments = Nothing
Set openMsg = Nothing
' end do whatever
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Edited : How to add the reference
Click Tools > Reference.
Check the needed reference