I would like to run a macro to do follow steps:
- save PDF only attachment to hard drive
- save it with a revise name filename & domain name.
Here is the code I search from open source and mix it together. any help is appreciated. thanks
Public Sub Download_Attachments()
Dim ns As NameSpace
Dim olFolder_Inbox As Folder
Dim olMail As MailItem
Dim olAttachment As Attachment
Dim strFolderPath As String
Dim strFileName As String
Dim strSenderAddress As String
Dim strSenderDomain As String
Dim fso As Object
strFolderPath = "C:\"
Set ns = GetNamespace("MAPI")
Set fso = CreateObject("Scripting.FileSystemObject")
Set olFolder_Inbox = Application.ActiveExplorer.CurrentFolder
Set olMail = Application.ActiveWindow.CurrentItem
'Get sender domain
strSenderAddress = olMail.SenderEmailAddress
strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "#"))
For Each olMail In olFolder_Inbox.Items
If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 Then
For Each olAttachment In olMail.Attachments
Select Case UCase(fso.GetExtensionName(olAttachment.FileName))
Case "PDF", "pdf"
olAttachment.SaveAsFile strFolderPath & strFileName
Case Else
'skip
End Select
Next olAttachment
End If
Next olMail
Set olFolder_Inbox = Nothing
Set fso = Nothing
Set ns = Nothing
End Sub
The following line of code retrieves the active folder in the Explorer window, not the Inbox one. Outlook can be started with any active folder, you can specify the folder name to the Outlook.exe file. To get the default folders (Inbox) you need to use the NameSpace.GetDefaultFolder method which returns a Folder object that represents the default folder of the requested type for the current profile; for example, obtains the default Calendar folder for the user who is currently logged on. For example, the following sample code uses the CurrentFolder property to change the displayed folder to the user's default Inbox folder.
Sub ChangeCurrentFolder()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
Set Application.ActiveExplorer.CurrentFolder = myNamespace.GetDefaultFolder(olFolderInbox)
End Sub
Then it is not really recommended to iterate over all items in the folder.
For Each olMail In olFolder_Inbox.Items
Instead, you need to use the Find/FindNext or Restrict methods of the Items class to get only items that correspond to your conditions. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Finally, the part you are interested in is the SaveAsFile method of the Attachment class which saves the attachment to the specified path:
olAttachment.SaveAsFile strFolderPath & domainName & strFileName
Make sure a qualified file path is passed as a parameter. I'd recommend running the code under the debugger and see what values are passed.
Related
I'm trying to convert an email to task and place that task inside a shared task folder. My co-worker shared the folder and has given me owner access to the folder as well.
We have utilized the script on slipstick to accomplish this. This code does work for my co-worker, but does not work for me.
When I dig into the list of folders I see my personal task list as a folder and not the shared folder. (Via the code below)
Is there any way that I can add a task to a shared task folder?
Public strFolders As String
Public Sub GetFolderNames()
Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Dim lCountOfFound As Long
lCountOfFound = 0
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
' Allow the user to pick the folder in which to start the search.
Set olStartFolder = olSession.PickFolder
' Check to make sure user didn't cancel PickFolder dialog.
If Not (olStartFolder Is Nothing) Then
' Start the search process.
ProcessFolder olStartFolder
End If
' Create a new mail message with the folder list inserted
Set ListFolders = Application.CreateItem(olMailItem)
ListFolders.Body = strFolders
ListFolders.Display
' clear the string so you can run it on another folder
strFolders = ""
End Sub
Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)
Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempFolder As Outlook.MAPIFolder
Dim olTempFolderPath As String
' Loop through the items in the current folder.
For i = CurrentFolder.Folders.Count To 1 Step -1
Set olTempFolder = CurrentFolder.Folders(i)
olTempFolderPath = olTempFolder.FolderPath
' Get the count of items in the folder
olCount = olTempFolder.Items.Count
'prints the folder path and name in the VB Editor's Immediate window
Debug.Print olTempFolderPath & " " & olCount
' prints the folder name only
' Debug.Print olTempFolder
' create a string with the folder names.
' use olTempFolder if you want foldernames only
strFolders = strFolders & vbCrLf & olTempFolderPath & " " & olCount
lCountOfFound = lCountOfFound + 1
Next
' Loop through and search each subfolder of the current folder.
For Each olNewFolder In CurrentFolder.Folders
'Don't need to process the Deleted Items folder
If olNewFolder.Name <> "Deleted Items" Then
ProcessFolder olNewFolder
End If
Next
End Sub
In addition the Task folder, you will need permission to your co-worker's Mailbox. (Not Inbox nor other folders.)
If you add the mailbox to your profile, see the accepted answer here.
If you do not add the mailbox to your profile, see the answer describing GetSharedDefaultFolder. Redemption is not required.
I want to search ALL my outlook for latest message in a conversation (I use Subject name as search key).
This latest message can be in Inbox, Sent Items, in a sub folder of Inbox, a sub-sub folder of Inbox (anywhere).
I can achieve this by some very tedious code, going through every level of each major folder, but not only this method is very messy, I can't determine if this found message is the latest in this conversation.
I have the following code, which
--> Searches Inbox for "searchKey"
--> If finds it in Inbox folder, replies to it
--> If not, it moves into subfolders of Inbox, and continues the same process
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr
tryAgain:
For Each olMail In olFldr.Items
If InStr(olMail.Subject, searchKey) <> 0 Then
Set ReplyAll = olMail.ReplyAll
With ReplyAll
.HTMLBody = Msg & .HTMLBody
emailReady = True
.Display
End With
End If
Next olMail
If Not emailReady Then
i = i + 1
If i > Fldr.Folders.Count Then
MsgBox ("The email with the given subject line was not found!")
Exit Sub
Else
Set olFldr = Fldr.Folders(i)
GoTo tryAgain
End If
End If
This code might be confusing and long, so please let me know if you need any clarification.
The question is: How can I search through ALL Outlook, without going manually through every folder/subfolder/sub-subfolder... without this method, and find the LAST message in a specific conversation? Or, at least, how can I optimize this code so I don't miss any folder, and know the dates and times these emails were sent?
You can use the built in AdvancedSearch function, which returns a Search object containing items.
These should have date properties, so you only need your code to go through the search object mailItems and find that with the latest date ( ReceivedTime)?
I would suggest using the bottom example on that page - it gets a table object from the search, and then you use
Set MyTable = MySearch.GetTable
Do Until MyTable.EndOfTable
Set nextRow = MyTable.GetNextRow()
Debug.Print nextRow("ReceivedTime")
Loop
From there, you can do the comparison to find the latest time, and if you want to do something with the mailitem you would need to obtain the "EntryID" column from the table.
Then use the GetItemFromID method of the NameSpace object to obtain a full item, since the table returns readonly objects.
You can also apply a date filter to the search if you wish, if you knew a minimum date for instance.
To go through all folders do this:
Go once through all the primary folders in Outlook and then for each major folder go through each subfolder. If you have more branches then is guess you have to add more levels to the code "for each Folder3 in folder2.folders". Also in the if clause you can test the date of the mail and go from the newest to the oldest. Set oMsg.display to see what mail is being checked
Public Sub FORWARD_Mail_STAT_IN()
Dim Session As Outlook.NameSpace
Dim oOutLookObject As New Outlook.Application
Dim olNameSpace As NameSpace
Dim oItem As Object
Dim oMsg As Object
Dim searchkey As String
Set oOutLookObject = CreateObject("Outlook.Application")
Set oItem = oOutLookObject.CreateItem(0)
Set olNameSpace = oOutLookObject.GetNamespace("MAPI")
Set Session = Application.Session
Set Folders = Session.Folders
For Each Folder In Folders 'main folders in Outlook
xxx = Folder.Name
For Each Folder2 In Folder.Folders 'all the subfolders from a main folder
yyy = Folder2.Name
Set oFolder = olNameSpace.Folders(xxx).Folders(yyy) 'in each folder we search all the emails
For Z = oFolder.Items.Count To 1 Step -1 ' For Z = 1 To oFolder.Items.Count
With oFolder.Items(Z)
Set oMsg = oFolder.Items(Z)
If Format(oMsg.SentOn, "mm/dd/yyyy") = Format(Date, "mm/dd/yyyy") And InStr(1, LCase(oMsg.Subject), searchkey, vbTextCompare) > 0 Then
oMsg.display
' insert code
End If
End With
Next Z
Next Folder2
Next Folder
Recently I am trying to create a function which selects specific folders.
I tested this at one user and it works. The problem however is that I also want to use this function at other users but not having to rewrite the function based on their folder structure.
The function works with a few folder names which all of them have (same names).
It consists of 1 main folder: #MemoScan and 4 sub-folders.
Based on these folder names I want to count how many mail items are in them.
I created the following function to do this:
Function HowManyEmails() As Integer
Dim objOutlook As Object, objnSpace As Object, MyCurrentFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set MyCurrentFolder = objnSpace.folders("William").folders("#MemoScan")
sFolder = MyCurrentFolder
For Each Folder In MyCurrentFolder.folders
sFolder = Folder
sSubmap = Right(sFolder, Len(sFolder) - 1)
For Each Item In Folder.Items
If TypeName(Item) = "MailItem" Then
EmailCount = EmailCount + 1
End If
Next Item
Next Folder
HowManyEmails = EmailCount
End Function
As you can see the folder that needs to be checked is hard-coded (needs to be since it runs on a close outlook event and nothing is selected).
The path now is: objnSpace.folders("William").folders("#MemoScan")
The thing is however that the main account/folder William wont be there at other users. My question is, how can I adjust it in such way that it will just look for the #MemoScan folder which is of the same at every user? Is this even possible?
If I leave the main William namespace out then it won't be able to find the #MemoScan folder.
The folder structure at this particular user is as follows:
The Namespace class provides the Stores property which returns a Stores collection object that represents all the Store objects in the current profile. The Store class provides the GetRootFolder method which returns a Folder object representing the root-level folder of the Store. You can use the GetRootFolder method to enumerate the subfolders of the root folder of the Store. Unlike NameSpace.Folders which contains all folders for all stores in the current profile, Store.GetRootFolder.Folders allows you to enumerate all folders for a given Store object in the current profile.
Sub EnumerateFoldersInStores()
Dim colStores As Outlook.Stores
Dim oStore As Outlook.Store
Dim oRoot As Outlook.Folder
On Error Resume Next
Set colStores = Application.Session.Stores
For Each oStore In colStores
Set oRoot = oStore.GetRootFolder
Debug.Print (oRoot.FolderPath)
EnumerateFolders oRoot
Next
End Sub
Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder)
Dim folders As Outlook.folders
Dim Folder As Outlook.Folder
Dim foldercount As Integer
On Error Resume Next
Set folders = oFolder.folders
foldercount = folders.Count
'Check if there are any folders below oFolder
If foldercount Then
For Each Folder In folders
Debug.Print (Folder.FolderPath)
EnumerateFolders Folder
Next
End If
End Sub
Also you can run the code against the currently selected folder in Outlook. The CurrentFolder property of the Explorer class returns a Folder object that represents the current folder displayed in the explorer.
I have the following code which I believe should work to save attachments from an Outlook subfolder to the specified path, before emptying the subfolder.
Sub Downloadattachments()
Dim applOutlook As Outlook.Application
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim SubFolder As MAPIFolder
Dim SubSubFolder As MAPIFolder
Dim VariableName As Name
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = inbox.Folders("Paul")
Set SubSubFolder = SubFolder.Folders("Soja")
i = 0
If SubSubFolder.Items.Count = 0 Then
MsgBox
Else: End If
If SubSubFolder.Items.Count > 0 Then
For Each item In SubSubFolder.Items
For Each atmt In item.attachments
FileName = "\\homefolder5\bases" & atmt.FileName
atmt.SaveAsFile FileName
i = i + 1
item.Delete
Next atmt
Next item
End If
End Sub
Unfortunately I don't get past the line Set ns = GetNamespace("MAPI") before encountering the run-time error stating "Automation error: Library not registered". To clarify, I have the Microsoft Outlook 14.0 Object Library activated, along with other basic libraries. I think this must be something different.
I apologize if this is a really simple thing that I am overlooking, but I would appreciate whatever guidance you could give me!
Where do you run the VBA macro?
Dim applOutlook As Outlook.Application
It looks like you didn't initialize the applOutlook object in the code. If you develop an Outlook VBA macro, you can use the Application property:
Set applOutlook = Application
Set ns = applOutlook.GetNamespace("MAPI")
In case if you automate Outlook you need to create a new instance of the Application class. See How to automate Outlook from another program for more information.
I have a created folder in my outlook named "Reports". This folder contains emails with one attachment in each email. I would like to use ACCESS VBA to save the attachments from the "Reports" folder in Outlook to a local drive in my computer. here is the code I have so far, but gives me errors. Please help:
Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim folder As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("Reports") // I get an error in this line says an object could not be found
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Atmt.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
Next Item
Is your Reports folder within your Inbox folder? You may need to do something like this:
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set RptFolder = Inbox.Folders("Reports")
Your syntax for saving attachments looks correct (apart from your comments not being correct for VBA). You could print out the Filename that you are creating to see if it's a valid name. And I assume that you have created the Automation folder that you mention.
Update:
Try declaring your Atmt as an Outlook.Attachment. There is such a thing as an Access.Attachment which does not have a SaveAsFile method, and it's probably picking that one up first. If you include the library name, you should get the one you need.
Update 2:
To get to your Reports folder, one way is to get the Inbox folder as you are currently doing, then get its parent, then get the Reports folder under that.
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set Mailbox = Inbox.Parent
Set RptFolder = Mailbox.Folders("Reports")
Another way would be to scan the items under "ns" to find the one that starts with "Mailbox", then get the Reports folder under that. It seems a little more cumbersome than getting the parent of the inbox. That also seems cumbersome, but I couldn't find a way to get to the Mailbox folder directly.
Replace
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Atmt.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
With.....
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Attachments.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
Outlook does not have a problem with atmt in the reference however, MS Access does. This should fix your problem.
Davis Rogers
Replace
Dim Atmt As Attachment
with
Dim Atmt As Outlook.Attachment
It'll make Access find the correct Class for atmt.