I'm having issues with getting some code to work. I have put it together from code I found and get an error stating the Sub or Function is not defined. I'm new to Outlook VBA and can't figure it out.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
'Set the folder and items to watch:
'Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
'Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set objWatchFolder = objNS.Inbox.Folders.Item("Zip Files")
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Date6months = DateAdd("d", 0, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders.Item("Zip Files")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
For i = ItemsOverMonths.Count To 1 Step -1
ItemsOverMonths.Item(i).Delete
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
If anyone can point me in the right direction that would be great.
See the Changes I made and compare it with yours
Option Explicit
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Zip Files")
Set objItems = objWatchFolder.Items
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
DeleteOlderThan6months Item
End If
End Sub
'https://stackoverflow.com/questions/37060954/trouble-setting-the-subfolder
Sub DeleteOlderThan6months(ByVal Item As Object)
'// Declare variables
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim oItem As Object
Dim i As Long
'// set your inbox and subfolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders("Zip Files")
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
' // Loop through the Items in the folder backwards
For i = ItemsOverMonths.Count To 1 Step -1
Set oItem = ItemsOverMonths.Item(i)
If TypeOf oItem Is Outlook.MailItem Then
Debug.Print oItem.Subject
oItem.Delete
End If
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
Tested on Outlook 2010.
Related
I've been playing around with the below code in an attempt to save files which we receive daily in Outlook. The code seems to run fine, however, when I go to check the destination folder there are no attachments saved.
How can I modify the code to save the attachments to the specified folder?
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "made-up-email#some_domain.com") And _
(Msg.Subject = "Test") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "T:\London File3 Group\Client Reporting\Test"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
End Sub
This code should work, something you may not have done is added this to the ThisOutlookSession object. Don't add to a standard module.
Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\"
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem: Set Msg = Item
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Filename As String
If Not TypeName(Msg) = "MailItem" Then Exit Sub
If (Msg.SenderName = "made-up-email#some_domain.com") And (Msg.Subject = "Test") And (Msg.Attachments.Count >= 1) Then
Set myAttachments = Item.Attachments
Filename = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Filename
Msg.UnRead = False
End If
End Sub
I want to save Outlook attachments to a shared drive.
The below script saves attachments from my own inbox. I want to save attachments from a subfolder of a shared mailbox.
Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\ABI Daily\"
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem: Set Msg = Item
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Filename As String
If Not TypeName(Msg) = "MailItem" Then Exit Sub
If (Msg.Subject Like "*Trade*") Or (Msg.Subject Like "*Trades*") Or _
(Msg.Subject Like "*Article 59*") Or (Msg.Subject Like "*Val*") Or _
(Msg.Subject Like "*Valuation*") Or (Msg.Subject Like "*Trading*") Or _
(Msg.Subject Like "*St James*") Then
Set myAttachments = Item.Attachments
Filename = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Filename
Msg.UnRead = False
End If
End Sub
Work with GetSharedDefaultFolder Method which Returns a MAPIFolder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders
Example
Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\ABI Daily\"
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
Dim ShrdRecip As Outlook.Recipient: Set ShrdRecip = objectNS.CreateRecipient("0m3r#email.com")
Set InboxItems = GetSharedDefaultFolder(ShrdRecip, olFolderInbox).Items
End Sub
Edit
Example for subfolder
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim ShrdRecip As Outlook.Recipient
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set ShrdRecip = olNs.CreateRecipient("0m3r#email.com")
Set Inbox = olNs.GetSharedDefaultFolder(ShrdRecip, olFolderInbox) _
.Folders("FolderName")
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Debug.Print Item.Subject ' print on Immediate window
End If
End Sub
I need a macro that will move messages received into a shared mailbox to a subfolder of that mailbox, depending on the sender's email address, basically a normal outlook rule.
I've been looking at some articles on http://www.slipstick.com/ which has got me part way there but there isn't an exact solution for what I want to do and I'm not proficient enough with VBA in Outlook yet to work it out.
So far I've got this code on ThisOutlookSession to watch the mailbox:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
End Sub
And this function in a module to obtain the path of the watched mailbox folder:
' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
This works, I used a case to move the item if it came from a specific email address:
Dim i As Long
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.Session
Set olInboxItems = GetFolderPath(">Digital Analytics\Inbox").Items
Set objNS = Nothing
For Each Item In olInboxItems
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim objDestFolder As Outlook.MAPIFolder
Dim destFolder As String
Dim sendersAddress As String
If Item.Class = olMail Then
sendersAddress = Item.SenderEmailAddress
Select Case sendersAddress
Case "no-reply#omniture.com"
destFolder = ">Digital Analytics\Inbox\Reports"
Case "no-reply#edigitalresearch.com"
destFolder = ">Digital Analytics\Inbox\Reports"
End Select
Set objDestFolder = GetFolderPath(destFolder)
Item.Move objDestFolder
End If
End Sub
I'm new to Outlook VBA and having a tough time figuring out how to set my subfolder in the code below. I have been trouble shooting this all day. Not sure what I'm missing.
Sub DeleteOlderThan6months()
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
Set oFolder = oFolder.Folders("My#email.com").Folders("Inbox").Folders("Zip Files")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
For i = ItemsOverMonths.Count To 1 Step -1
ItemsOverMonths.Item(i).Delete
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
This should do it, see how i set the subfolder
Option Explicit
Sub DeleteOlderThan6months()
'// Declare variables
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim oItem As Object
Dim i As Long
'// set your inbox and subfolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders("Zip Files")
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
'// Loop through the Items in the folder backwards
For i = ItemsOverMonths.Count To 1 Step -1
Set oItem = ItemsOverMonths.Item(i)
If TypeOf oItem Is Outlook.MailItem Then
Debug.Print oItem.Subject
oItem.Delete
End If
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
set oFolder = Inbox.Folders.Item("Zip Files")
So I am trying to create a Macro that will search my e-mails based on a piece of information on an access form I know I am close but I cannot seem to figure out the final piece
Private Sub btnEMAIL_Click()
Dim strID As String, strMessages As String
Call Outlook_open 'CHECKS TO SEE IF OUT LOOK IS OPEN
Dim myOlApp As Object
Set myOlApp = CreateObject("Outlook.Application") 'Creates outlook object
strID = PayeeID.Value 'this is a value on the form
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim blnfound As Boolean
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.Folders("HQP Field Compensation").Folders("Inbox")
Set myitems = myInbox.Items
Set mySearch = AdvancedSearch(Scope:=myInbox,Filter:="urn:schemas:mailheader:subject= '" & strID & "'")
Set myResults = mySearch.Results
If myResults.Count > 0 Then
For intCounter = 1 To myResults.Count
myResults.Item(intCounter).Display 'Should display the relevant e-mail
Next intCounter
End If
End Sub
AdvancedSearch is asynchronous/ Since you are only searching through the Inbox, use Items.Restrict or Items.Find/FindNext
set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
set myItems = myInbox.Items
set myItem = myItems.Find("[Subject]='" & strID & "'")
while Not (myItem Is Nothing)
myItem.Display
set myItem = myItems.FindNext
wend