Accessing custom fields uses a couple more lines of code and will be easier to get the value in a variable, although not 100% required. You can't just say 'item.custonfieldname' though.
Set UserProp = obj.UserProperties.Find("fieldname")
If Not UserProp Is Nothing Then
strCurrent = obj.UserProperties("fieldname").Value
End If
A sample code is at the end of this article -
How to create a custom field to mark messages that were responded to in Microsoft Outlook.
www.slipstick.com
Diana,
Thank you for your answer!
I have tried to understand it and what I tried, it doesn't work.
The VBA below is a part of a email manager I found on the internet.
There are some Dutch sentences in it.
De line I have tried, the text is red colored
In other thing is that if de mail is forwarded the ID stays in de new incoming mail. If you do a reply it is gone.
Is there a solution for the reply mail to keep the ID?
Option Explicit
Const xlUp As Long = -4162 ' Set the enumeration for Excel's xlup Outlook kent geen xlup. De Code hiervoor is -4162 die opgeslagen wordt in een constantehmet de naam xlUp.
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.Folders("
adress@gmail.com").Folders("Inbox").Items ' Change These Folder Names to whatever names are in your Outlook
' Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem
Dim ExApp As Object
Dim ExWb As Object
Dim Attach As Attachment
Dim AttachFolder As String
Dim FileName As String
Dim EmailText As String
Dim EmailRow As Long
Dim AttachRow As Long
Dim AttachNum As Long
Dim FileNumb As Long
Dim ErrNumb As Long
Dim WkBkOpen As Boolean
If TypeName(Item) = "MailItem" Then
FileName = "C:\Mailmanager\Outlook_Email_Manager.xlsm" ' Customize this to your workbook location
If FileName = "" Then
MsgBox "De locatie van het excel bestand is niet bekend, pas de variable 'FileName' aan in de macro!"
Exit Sub
End If
' Determine If Excel File is open or not
On Error Resume Next
FileNumb = FreeFile() ' Get Free File #
Open FileName For Input Lock Read As #FileNumb ' Attempt to open the file and lock it.
Close FileNumb ' Close the file.
ErrNumb = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
Select Case ErrNumb ' Check to see which error occurred
Case 0 ' File is NOT already open by another user.
WkBkOpen = False ' Error number for "Permission Denied"
Case 70 ' File is already opened by another user.
WkBkOpen = True
Case Else ' Another error occurred.
Error ErrNumb
End Select
' Start Excel
On Error Resume Next
Set ExApp = GetObject(, "Excel.Application") 'Set EXCEL application object
On Error GoTo 0
If ExApp Is Nothing Then
Set ExApp = CreateObject("Excel.Application")
End If
ExApp.Visible = True 'Make Excel Application Visible
If WkBkOpen = True Then 'Check If workbook is open
Set ExWb = GetObject(FileName).Application 'PAD + BESTAND
Else:
Set ExWb = ExApp.Workbooks.Open(FileName) 'PAD + BESTAND
End If
' First Available Row in Workbook
EmailRow = ExWb.Sheets("Email Db").Range("A999999").End(xlUp).Row + 1 ' (xlUp) is de constante, dit had ook (-4162) mogen zijn.
EmailText = Item.Body
With ExWb.Sheets("Email Db") ' Email DB Sheet
.Range("A" & EmailRow).Value = Item.ReceivedTime ' Email Received On
.Range("B" & EmailRow).Value = Item.SenderEmailAddress ' From Email
' .Range("C" & EmailRow).Value = Item.SenderName ' From Name
.Range("D" & EmailRow).Value = Item.Subject ' Subject
' .Range("E" & EmailRow).Value = EmailText ' Message
.Range("F" & EmailRow).Value = "Default Category" ' Default Category?"
' .Range("G" & EmailRow).Value = Item.Attachments.Count ' Count number of attachments
.Range("I" & EmailRow).Value = Item.ID ' User identification
End With
If WkBkOpen = False Then ExWb.Close (True) ' Save & Close Workbook if Previously closed
If WkBkOpen = False Then ExApp.Quit ' Quit Excel Application ir previously closed
End If
End Sub
