I am trying to apply a filter using the restrict method of mail items using Outlook VBA. Below code works fine if I use only one restrict method based on Category_Filter variable, but when I try to use two restrict methods,
Somehow my Flag_Filter fails.
I believe I am making some mistake in concatenation for Flag_Filter and need some clue here.
Sub ApplyFilters()
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 OrderNumber, Category_Filter, Flag_Filter As String
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
OrderNumber = "GCU5689"
Category_Filter = "[Categories] = 'Textile'"
Flag_Filter = "[FlagRequest] = " & OrderNumber
For Each i In fol.Items.Restrict(Category_Filter).Restrict(Flag_Filter)
' Some actions
Next i
End Sub
You cannot restrict a restricted collection. You need to combine the restrictions (using "and" ) into a single query and call Restrict only once.
like #Dmitry Streblechenko says use And Operator (Visual Basic) MSDN with your Outlook restrict method
Example
Option Explicit
Private Sub Examples()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Msg As String
Dim i As Long
Dim Filter As String
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Filter = "[Categories] = 'Textile' And [FlagRequest] = 'Follow up'"
Set Items = Inbox.Items.Restrict(Filter)
Msg = Items.Count & " Items in " & Inbox.Name
If MsgBox(Msg, vbYesNo) = vbYes Then
For i = Items.Count To 1 Step -1
Debug.Print Items(i) 'Immediate Window
Next
End If
End Sub
More examples here
for variable you can use the chr(34) function to represent the double quote (whose ASCII character value is 34) that is used as an escape character or use double quote.
Example
Dim OrderNumber As String
OrderNumber = "GCU5689"
Filter = "[Categories] = 'Textile' And [FlagRequest] = '" & OrderNumber & "'"
In general you may apply multiple actions one at a time. Such an approach allows easier troubleshooting.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Sub ApplyFilters()
Dim ns As NameSpace
Dim fol As folder
Dim i As Object
Dim mi As MailItem
Dim resItms As Items
Dim OrderNumber As String
Dim Category_Filter As String
Dim Flag_Filter As String
Set ns = GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
OrderNumber = "GCU5689"
Category_Filter = "[Categories] = 'Textile'"
Flag_Filter = "[FlagRequest] = " & OrderNumber
Set resItms = fol.Items.Restrict(Category_Filter)
Debug.Print "Items after first restrict: " & resItms.Count
Set resItms = resItms.Restrict(Flag_Filter)
Debug.Print "Items after second restrict: " & resItms.Count
For Each i In resItms
' Some actions
' If, for instance, a property is only found on mailitems
If i.Class = olmail Then
Set mi = i
Debug.Print mi.Subject
End If
Next
End Sub
Related
I found VBA code to sync my Outlook calendar with OneNote.
On line 7, I get
User-defined type not defined.
I have One Note 15 and Outlook 16 selected in references.
Sub SyncCalendarWithOneNote()
Dim olApp As Outlook.Application
Dim olCalendar As Outlook.Folder
Dim olItems As Outlook.Items
Dim olItem As Object
Dim onApp As OneNote.Application
Dim onNotebook As OneNote.Notebook
Dim onSection As OneNote.Section
Dim onPage As OneNote.Page
Dim onPageContent As String
Dim onPageID As String
' Connect to Outlook and OneNote
Set olApp = Outlook.Application
Set onApp = OneNote.Application
' Get the calendar folder and its items
Set olCalendar = olApp.Session.GetDefaultFolder(olFolderCalendar)
Set olItems = olCalendar.Items
' Loop through the calendar items
For Each olItem In olItems
' Check if the item is an appointment
If TypeOf olItem Is Outlook.AppointmentItem Then
' Get the appointment information
Dim olSubject As String
Dim olStart As Date
Dim olEnd As Date
olSubject = olItem.Subject
olStart = olItem.Start
olEnd = olItem.End
' Create a OneNote page for the appointment
Set onNotebook = onApp.ActiveNotebook
Set onSection = onNotebook.Sections("Calendar")
onApp.CreateNewPage Onenote.nsHierarchyScopeSection, onSection.ID, onPageID
Set onPage = onApp.GetPageContent(onPageID)
onPageContent = "Subject: " & olSubject & vbCrLf & _
"Start: " & olStart & vbCrLf & _
"End: " & olEnd
onApp.UpdatePageContent onPage.ID, onPageContent
End If
Next
' Clean up
Set olCalendar = Nothing
Set olItems = Nothing
Set olItem = Nothing
Set onApp = Nothing
Set onNotebook = Nothing
Set onSection = Nothing
Set onPage = Nothing
End Sub
I want to sync Outlook Calendar with OneNote where a new note will be created for each calendar event.
I have the following scenario. Populate a listbox1 with emails from InBox. I am using the
followings approach (Loop'For Each' and Sql '1 to count'):
LOOP
Sub Example_LOOP()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Dim Item As Object
Dim textDisplay As String
Dim resultReceived As String
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
For Each Item In olFolder.Items
If TypeOf Item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = Item
textDisplay = oMail.Sender & " | " & oMail.Subject & " | " & oMail.ReceivedTime
resultReceived = textDisplay & "§" & resultReceived
End If
Next
With Me.ListBox1
.Clear
.List = Split(resultReceived, "§")
.RemoveItem (Me.ListBox1.ListCount - 1)
End With
End Sub
and SQL:
Public Sub Example_SQL()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder: Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim Items As Outlook.Items
Dim Item As Object
Dim i As Long
Dim Filter As String
Dim textDisplay As String
Dim resultReceived As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & _
Chr(34) & "Like ''"
Set Items = olFolder.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", 1
For i = Items.Count To 1 Step -1
If TypeOf Items(i) Is MailItem Then
Set Item = Items(i)
textDisplay = Item.Sender & " | " & Item.Subject & " | " & Item.ReceivedTime
resultReceived = textDisplay & "§" & resultReceived
End If
Next
With Me.ListBox1
.Clear
.List = Split(resultReceived, "§")
.RemoveItem (Me.ListBox1.ListCount - 1)
End With
End Sub
Reading 10000 emails takes around 45 seconds. It is possibility to do it faster. Or maybe a different approach?
Thank you.
You can use Tables from the Outlook object model where you can specify only properties you are interested in. So, instead of loading in the loop each item from a folder you may iterate over rows in a table which I think can be much faster.
The Folder.GetTable method obtains a Table object that contains items filtered by Filter. By default, TableContents is olUserItems and the returned Table contains only the filtered items that are not hidden. If Filter is a blank string or the Filter parameter is omitted, GetTable returns a Table with rows representing all the items in the Folder.
GetTable returns a Table with the default column set for the folder type of the parent Folder. To modify the default column set, use the Add, Remove, or RemoveAll methods of the Columns collection object. You can use Table.Restrict to apply subsequent filters to a Table that is based on the Folder object. For example:
Sub DemoTable()
'Declarations
Dim Filter As String
Dim oRow As Outlook.Row
Dim oTable As Outlook.Table
Dim oFolder As Outlook.Folder
'Get a Folder object for the Inbox
Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox)
'Define Filter to obtain items last modified after May 1, 2021
Filter = "[LastModificationTime] > '5/1/2021'"
'Restrict with Filter
Set oTable = oFolder.GetTable(Filter)
'Enumerate the table using test for EndOfTable
Do Until (oTable.EndOfTable)
Set oRow = oTable.GetNextRow()
Debug.Print (oRow("Subject"))
Debug.Print (oRow("LastModificationTime"))
Loop
End Sub`
In addition to Eugene's suggestion, do not load all items. Load them on demand as the user scrolls through the list.
I have done it like this, and it is working fine (I can add only the properties that I'm looking for). Thanks to show me the direction. :)
Public Sub ExtractInBoxInfo()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim oFolder As Outlook.MAPIFolder: Set oFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim oTable As Outlook.Table
Dim oRow As Outlook.Row
Dim Filter As String
Dim textDisplay As String
Dim resultReceived As String
Filter = "[LastModificationTime] > '1/1/1900'"
Set oTable = oFolder.GetTable(Filter)
oTable.Columns.RemoveAll
With oTable.Columns
.Add ("SenderName")
'.Add ("SenderEmailAddress")
.Add ("Subject")
.Add ("LastModificationTime")
End With
Do Until (oTable.EndOfTable)
Set oRow = oTable.GetNextRow()
textDisplay = oRow("SenderName") & " | " & oRow("Subject") & " | " & oRow("LastModificationTime")
resultReceived = textDisplay & "§" & resultReceived
Loop
With Me.ListBox1
.Clear
.List = Split(resultReceived, "§")
.RemoveItem (Me.ListBox1.ListCount - 1)
End With
End Sub
I'm trying to export sender email address and recipient email addresses (to and cc) to Excel. I adapted code I found online. It does most of what I need but there are two problems:
It only works with a single recipient. If there are two or more recipients, it provides names (e.g. Jo Bloggs) instead of email addresses.
It only includes people in the 'To' field, not those in the 'CC' field.
I think the bit that needs fixing is:
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
Full code:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim olItem 'As Outlook.MailItem
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
xlSheet.Range("A1") = "Sender Name"
xlSheet.Range("B1") = "Sender Email"
xlSheet.Range("C1") = "Subject"
xlSheet.Range("D1") = "Body"
xlSheet.Range("E1") = "Sent To"
xlSheet.Range("F1") = "Date"
End If
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each obj In objItems
Set olItem = obj
'collect the fields
strColA = olItem.SenderName
strColB = olItem.SenderEmailAddress
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)
If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
xlWB.Save
Next
' don't wrap lines
xlSheet.Rows.WrapText = False
xlWB.Save
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Iterating through all items in the folder is not really a good idea. I'd recommend starting from the Find/FindNext or Restrict methods instead. Please note that there are some item properties that you can’t use for the filter. You can read more about the properties not allowed in the filter string and string formats used for the search criterion on MSDN.
The following example uses the Restrict method to get all Inbox items of Business category and moves them to the Business folder. To run this example, create or make sure a subfolder called 'Business' exists under Inbox:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Categories] = 'Business'")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Please remember that you can set a suitable filter (View | View Settings |filter) on a folder and study the filter string on the SQL tab of the Filter dialog. Then you can construct any required filter string in the code.
If woudl be nice to use Items.Find/FindNext or Items.Restrict, but I cannot think of a query that would let you do what you want. If it is a one time thing, you have no choice but to loop through all items in a folder and for each item loop through all recipients and compare each recipient's entry id (Recipient.EntryID) with the sender entry id (MailItem.Sender.EntryId).
I have rules in Outlook for incoming and posted emails.
I found in the web the following routine which works for the emails which are in the 'INBOX'.
I am not able to use the GetRootFolder to select the 'Sent Items' folder.
The routine is the following:
Sub RunRules()
Dim st As Outlook.Store
Dim myRules As Outlook.rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim k As Long
Dim fname As String
Dim currentcount As Integer
Dim prova As String
Dim numero As Integer
Dim prova1 As String
Dim Nrules As Integer
Dim objFolder, objNamespace, objOutlook, objFile
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
objNamespace.Logon "Default Outlook Profile", , False, False
numero = 1
' this is for the SENT Items
fname = "I"
count = 1
k = 1
Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
'On Error Resume Next
' get default store (where rules live)
Set st = Application.Session.DefaultStore
Application.Session.DefaultStore.GetRootFolder (olFolderSentMail)
' get rules
Set myRules = st.GetRules
For k = 1 To myRules.count ' might be 0-based, didnt check
On Error Resume Next
Set rl = Nothing
Set rl = myRules(k)
If rl.RuleType = olRuleReceive Then 'determine if it’s an Inbox rule, if so, run it
' I selecto just the rules that are for the sent ITEMS
prova = rl.Name
prova1 = Left(prova, 1)
If prova1 = fname Then
rl.Execute ShowProgress:=True
objFile.WriteLine rl.Name
count = count + 1
prova = ""
prova1 = ""
End If
End If
Next
Set rl(count) = Nothing
Set st = Nothing
Set myRules = Nothing
Set objFolder = Nothing
End Sub
Sorry, I did not notice your question before.
I have not tried your code. Instead I show an extract from one of my routines which moves selected properties to variables from every mail item in the Sent Items folders.
Hope this helps.
Dim FolderTgt As MAPIFolder
Dim HtmlBody As String
Dim InxItemCrnt As Long
Dim ReceivedTime As Date
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String
Dim TextBody As String
Dim FolderTgt As MAPIFolder
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
For InxItemCrnt = FolderTgt.Items.Count To 1 Step -1
With FolderTgt.Items.Item(InxItemCrnt)
If .Class = olMail Then
' Save selected data to variables
ReceivedTime = .ReceivedTime
Subject = .Subject
SenderName = .SenderName
SenderEmailAddress = .SenderEmailAddress
TextBody = .Body
HtmlBody = .HtmlBody
End If
End With
Next
Unless specified, rules run on the Inbox of the default store, regardless of the store with the rules.
Option Explicit
Sub RunRules()
Dim st As Store
Dim myRules As rules
Dim rl As Rule
Dim count As Long
Dim k As Long
Dim fname As String
Dim prova As String
Dim prova1 As String
Dim objFolder As Folder
' this is for the SENT Items
fname = "I"
' get store (can be any store)
Set st = Session.defaultStore
' get rules from specified store
Set myRules = st.GetRules()
' The default folder is the Inbox of the default store,
' regardless of the store with the rules.
Set objFolder = st.GetDefaultFolder(olFolderSentMail)
Debug.Print "objFolder: " & objFolder
For k = 1 To myRules.count
Set rl = myRules(k)
Debug.Print rl.RuleType ' 0 = olRuleReceive, 1 = olRuleSend
If rl.RuleType = olRuleSend Then
' rule name starting with "I"
prova = rl.name
prova1 = Left(prova, 1)
If prova1 = fname Then
' Designate a folder if not the Inbox of the default store
rl.Execute ShowProgress:=True, Folder:=objFolder
count = count + 1
End If
End If
Next
Debug.Print count & " rules processed"
End Sub
I'm trying a different approach to something that I was working on the other day. At work, we use Outlook 2010 and receive emails with .XLSX attachments throughout the day. I'm trying to figure out how to use VBA in Outlook to check incoming emails for attachments, then if the attachment count is > 0, test the attachment and if it's a spreadsheet, update tblOutlookLog with the senders address book information. This is only my 2nd or third day experimenting with VBA outside of MS Access and I'm fumbling in the dark trying to figure out syntax. I've posted the code below from Outlook below. I get an error in the olInbox_ItemAdd(ByVal Item As Object) section at the .Subject line stating that it is an "invalid or unqualified reference". I apologize in advance in it's sloppy. Thank you for any assistance or direction.
Option Explicit
Private WithEvents InboxItems As Outlook.Items
Dim olns As NameSpace
Dim olInbox As MAPIFolder
Dim olItem As Object
Dim olAtmt As Attachment
Dim db As DAO.Database
Dim rst As DAO.Recordset
Const strdbPath = "\\FMI-FS\Users\sharp-c\Desktop\"
Const strdbName = "MSOutlook.accdb"
Const strTableName = "tblOutlookLog"
Private Sub Application_Startup()
Set olns = GetNamespace("MAPI")
Set olInbox = olns.GetDefaultFolder(olFolderInbox).Items
Set db = OpenDatabase(strdbPath & strdbName)
Set rst = db.OpenRecordset(strTableName, dbOpenDynaset)
End Sub
Private Sub Application_Quit()
On Error Resume Next
rst.Close
db.Close
Set olns = Nothing
End Sub
Private Sub olInbox_ItemAdd(ByVal Item As Object)
Dim olItem As Outlook.MailItem
Dim olAtmt As Outlook.Attachment
Dim strFoldername As String
Dim strFilename As String
Dim i As Integer
i = 0
For Each olItem In olInbox.Items
For Each olAtmt In olItem.Attachments
If olItem.olAtmt.Count > 0 Then
If Right$(olAtmt.FileName, 5) = ".xlsx" Then
strFilename = "\\FMI-FS\Users\sharp-c\Desktop\Test" & olAtmt.FileName
olAtmt.SaveAsFile strFilename
i = i + 1
rst.AddNew
rst!Subject = Left(.Subject, 255)
rst!Sender = .Sender
rst!FromAddress = .SenderEmailAddress
rst!Status = "Inbox"
rst!Logged = .ReceivedTime
rst!AttachmentPath = strFilename
Next
rst.Update
End If
Next olAtmt
Next olItem
Set olAtmt = Nothing
Set olItem = Nothing
End Sub
You need to prefix items with the object:
rst!Subject = Left(olItem.Subject, 255)
And so forth. I think you may have removed With at some stage.