asked on
Sub eBlastUpdateContact02User2BasedonEmailSentData()
Dim mai As MailItem
Dim UpdtCount As Integer, UpdtCount1 As Integer
Dim oOlApp As Outlook.Application
Dim objNmSpc As NameSpace
Dim ofldr As Object
Dim ContFldr As Object
Dim UpdateUserFieldYN As Integer
Dim ClearExistingUser2ContentYN As Integer
Dim olObject As Object
Dim olContact As Outlook.ContactItem
Dim propertyAccessor As Outlook.propertyAccessor, SentDate As Date
Dim BodyUpdate As Integer
Set oOlApp = Outlook.Application
Set objNmSpc = oOlApp.GetNamespace("MAPI")
MsgBox "Select Email Folder - Sent Emails"
Set ofldr = objNmSpc.PickFolder
MsgBox "Select Contacts Folder"
Set ContFldr = objNmSpc.PickFolder
MsgBox "Email Folder for Sent Emails - " & ofldr.FolderPath & vbNewLine & ofldr & vbNewLine & "Contacts - " & ContFldr.FolderPath & vbNewLine & ContFldr
BodyUpdate = MsgBox("Do You Want to Update the Contact Body?", vbYesNo) '2020-04-05
UpdateUserFieldYN = MsgBox("This Process Upadates User2 Field - Do You Want to Proceed?", vbYesNo)
If UpdateUserFieldYN = 6 Then
ClearExistingUser2ContentYN = MsgBox("Do you want to clear existing User2 Content from all contacts", vbYesNo)
If ClearExistingUser2ContentYN = 6 Then
UpdtCount1 = 1
For Each olObject In ContFldr.Items
If TypeName(olObject) = "ContactItem" Then
Set olContact = olObject
olContact.User2 = ""
olContact.Save
End If
UserForm1.TextBox1 = UpdtCount1
UserForm1.TextBox2 = "Contact " & UpdtCount1 & " " & olContact.FileAs
UserForm1.Show vbModeless
DoEvents
UpdtCount1 = UpdtCount1 + 1
Next
End If
UpdtCount = 1
For Each mai In ofldr.Items
'on error resume next
If mai.Class = olMail Then
With mai
Set propertyAccessor = mai.propertyAccessor
SentDate = Format(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E060040"), "mm-dd-yyyy")
Set olObject = ContFldr.Items.Find("[Email1Address] = " & .To)
If TypeName(olObject) = "ContactItem" Then
olObject.User2 = "Sent " & SentDate & " " & .Subject
If BodyUpdate = 6 Then olObject.Body = "Introduction Email Sent " & SentDate & " " & .Subject & vbNewLine & "-----------------" & vbNewLine & olObject.Body ' 2020-04-06
'2020-04-05 olObject.Save
End If
On Error Resume Next
UserForm1.TextBox1 = UpdtCount & "Email " & " " & .Subject
UserForm1.TextBox2 = UpdtCount & "Contact " & " " & olObject.FileAs
UserForm1.Show vbModeless
DoEvents
End With
End If
UpdtCount = UpdtCount + 1
Next
End If
Unload UserForm1
MsgBox "Macro Complete"
End Sub
run-time-error-440-cannot-parse-cond.JPG