VBA Outlook Email, update current/selected field before sending - vba

I wrote a macro, where the starting time of a meeting should be entered into the "Subject" Field of a meeting and the mail will be automatically send right after.
When I start the macro through a button and the last selected field like Subject or Start Time is selected and changed, the email will be send, but with the old data.
For example:
My last input to the email was the text "Test" in the empty Subject field. After that I send the email, through the button.
The email is sent, but the subject field remains empty.
Is there a way to update fields like subject and starttime?
I tried to use commands like update, SendKeys "{TAB}", myItem.Close olDiscard to close and update the field and send it right after.
Sub startTimeSend()
On Error GoTo HandleErr
Dim myItem As Object
Set myItem = Application.ActiveInspector.CurrentItem
Dim oldTitle As String
Dim startTime As String
Dim scanForOldNr As String
Dim newStartTimeFormat As String
' olPromptForSave
' SendKeys "{ENTER}"
' SendKeys "{ENTER}", True
' Application.SendKeys ("{ENTER}")
oldTitle = myItem.Subject
startTime = myItem.Start
' MsgBox (oldTitle)
' scanForOldNr contains third char (usually ":")
scanForOldNr = Mid(oldTitle, 3, 1)
If scanForOldNr Like "*:*" Then
' 7 da es von 1 hochzählt nicht null
' MsgBox (scanForOldNr)
oldTitle = Mid(oldTitle, 7)
End If
' Cancel = True
newStartTimeFormat = Format(startTime, "hh:mm")
myItem.Subject = newStartTimeFormat & " " & oldTitle
myItem.Send
ExitHere:
Exit Sub
HandleErr:
' Cancel = False
Resume ExitHere
End Sub

Outlook doesn't propagate changes made via OOM to the UI until you close and re-open the item. Or your changes made manually may not be visible in the OOM until the item is saved. I'd suggest dealing with proper OOM properties instead of inventing new mechanisms for sending and receiving data.
Use the AppointmentItem.Start property which returns or sets a Date indicating the starting date and time for the Outlook item. To get the associated appointment you can use the MeetingItem.GetAssociatedAppointment method.

Related

How to add multiple safe addresses in outlook

i have created a outlook macro where if i want to send email other then the listed email id,it will give me a popup. However, i am not being able to add multiple email ids to the list. please find the below code that i have written. Can someone please help me how to add multiple email ids in my below code?
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Const ADDR_TO_WATCH_FOR = "James.t#outlook.com"
Dim olkRec As Outlook.Recipient
If Item.Class = olMail Then
For Each olkRec In Item.Recipients
If LCase(olkRec.Address) <> ADDR_TO_WATCH_FOR Then
If MsgBox("This message is addressed to " & ADDR_TO_WATCH_FOR & ". Are you sure you want to send it?", vbQuestion + vbYesNo, "Confirm Send") = vbNo Then
Cancel = True
End If
Exit For
End If
Next
End If
Set olkRec = Nothing
End Sub
Don't show the message box inside the loop over all recipients. Run the loop first and check all recipients. Build a list of multiple recipients if necessary. After you exit the loop, check if that list (a string) if not empty, show the message box.

Treating Item As MailItem

I am creating an VBA application in Outlook 2016. It analyzes an incoming email and takes its subject line to search for duplicate (or close to duplicate) subject lines. I use a for-each loop to go through a list of Items (which are emails within the inbox) and analyze each one for the criteria.
Once a response is required, both the incoming email and the duplicate email are flagged so show that I have already responded to them.
I know both Item and olItem should both be Item objects. The problem I am having is in the line:
If InStr(1, GetPreceedingSubject(olItem.Subject), GetPreceedingSubject(SubjectString)) <> 0 _
And olItem.FlagRequest <> "Follow up" Then
It gives me the error
"Run-time error '438': Object doesn't support this property or method"
I know it is the olItem because it is the only part of the function that I had changed before I got the error. This strikes me as odd because the following snippet still works:
' flag both the emails that prompted the response
With Item
' due this week flag
.MarkAsTask olMarkThisWeek
' sets a specific due date
.TaskDueDate = Now + 3
.FlagRequest = "Follow up"
.FlagStatus = 2
.ReminderSet = False
.Save
End With
With olItem
' due this week flag
.MarkAsTask olMarkThisWeek
' sets a specific due date
.TaskDueDate = Now + 3
.FlagRequest = "Follow up"
.FlagStatus = 2
.ReminderSet = False
.Save
End With
So in the first code snippet, it appears that it is treating the olItem as an object, but in the next one it allows me to treat it like a MailItem object. Any suggestions? I have looked up ways to cast from Item to MailItem, even just temporarily for that line of code, but obviously to no avail. Full subroutine below:
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
If ParsingEnabled = False Then
Exit Sub
End If
Dim SubjectString As String ' tracks the control word to search the subject line for
Dim pingCount As Integer ' tracks the number of copies found.
Dim TimeDiff As Double
Dim Protocol As Variant
Dim FlagStatus As Integer
pingCount = 0
SubjectString = Item.Subject ' searches subject line for this word
' If the email is a read receipt, then move it to a different folder
If TypeName(Item) = "ReportItem" Then
NullPrompt = MoveFolders(Item, "Read")
If NullPrompt >= 0 Then
setLblDebug ("Read receipt: " & Mid(SubjectString, 7, Len(SubjectString)))
Item.UnRead = False
Else
NullPrompt = setLblDebug("Error when moving read receipt. Please check inbox and correct", lngRed)
End If
End If
' Check to make sure it is an Outlook mail message, otherwise
' subsequent code will probably fail depending on what type
' of item it is.
If TypeName(Item) = "MailItem" Then
' display the message
setLblDebug ("Incoming Message: " & Item.Subject)
Item.UnRead = False ' mark message as read
' Iterate through each item of the list
For Each olItem In myOlItems
If InStr(1, GetPreceedingSubject(olItem.Subject), GetPreceedingSubject(SubjectString)) <> 0 _
And olItem.FlagRequest <> "Follow up" Then
Protocol = ProtocolCode(Item.Subject)
If Protocol(0) <> 0 Then
' Time difference between the 2 emails
TimeDiff = (Item.ReceivedTime - olItem.ReceivedTime) * 24 ' Gives the hour difference
' If time difference is 0, then it is the same email
If Protocol(0) >= TimeDiff And TimeDiff <> 0 Then
' flag both the emails that prompted the response
With Item
' due this week flag
.MarkAsTask olMarkThisWeek
' sets a specific due date
.TaskDueDate = Now + 3
.FlagRequest = "Follow up"
.FlagStatus = 2
.ReminderSet = False
.Save
End With
With olItem
' due this week flag
.MarkAsTask olMarkThisWeek
' sets a specific due date
.TaskDueDate = Now + 3
.FlagRequest = "Follow up"
.FlagStatus = 2
.ReminderSet = False
.Save
End With
' email and call if required
RenderMail (olItem)
If Protocol(1) = 1 Then
NullPrompt = RenderCallPrompt(olItem.Subject, Item.ReceivedTime)
End If
' set the debug prompt message
NullPrompt = setLblDebug("Response Made: " & Item.Subject & " [" & Item.ReceivedTime & "]", lngBlue)
If True Then Exit For ' Reponse made, stop looking for additional emails
End If
End If
End If
Next olItem
End If
End Sub
You cannot treat an Object which is not a MailItem as a MailItem.
MailItem is a subset of Object. Object encompasses TaskItem, AppointmentItem and others.
Other types will not necessarily have the properties of a MailItem.
In your code:
' Check to make sure it is an Outlook mail message, otherwise
' subsequent code will probably fail depending on what type
' of item it is.
If TypeName(Item) = "MailItem" Then
Add the same test to ensure olItem is a MailItem.
For Each olItem In myOlItems
' Check to make sure it is an Outlook mail message, otherwise
' subsequent code will probably fail depending on what type
' of item it is.
If TypeName(olItem) = "MailItem" Then
'
End If
Next olItem

Detect if the last selected email has been marked as read and prompt to save

My outlook VBA code aims at doing the following:
In the event of selection change (i.e. say the user clicks on a different email in the inbox)
If [the previously selected email was originally 'Unread' and just became 'Read'] Then
Prompt the user to save the previous email
Else
Do Nothing
End If
To do that I used the Explorer_SelectionChange event. The problem I'm facing is that outlook takes about 1 to 2 seconds before it marks the previous email as read! My code gets executed before these 2 seconds pass. Hence it always sees the previous email as unread! :(
I tried to introduce a pause to my Sub but it didn't work. Outlook waits until my code finishes including the pause before it in turn waits 1 to 2 seconds and then mark the previous email as read.
So in summary my question is: Is there an Event that identifies when the previously selected email is marked as Read?? (PS: I tried MailItem.Read Event but it is also instantaneous and applies to all 'read and unread' emails]
Here is the part of my code that specifically tries to achieve the above described functionality:
Public WithEvents myOlExp As Outlook.Explorer
Dim Flag As Integer
Dim oMail As Outlook.MailItem
Private Sub Application_Startup()
Dim objItem As Object
Set myOlExp = Application.ActiveExplorer
enviro = CStr(Environ("USERPROFILE"))
'Identify the status of the selected email at startup
For Each objItem In myOlExp.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
End If
Next
If oMail.UnRead Then
Flag = 1 'Means Current selection is an unread email
Else
Flag = 0 'Means Current selection has been read before
End If
End Sub
Private Sub myOlExp_SelectionChange()
'If previous selected email was Unread
If Flag = 1 Then
If oMail.UnRead = False Then
MsgBox "previous email has just been read do you want to save?"
'^^This is where the problem happens: the previously selected email is always seen as read by the code
'because Outlook takes 1-2 seconds after the selection change event before it marks the email as read!!
Else
MsgBox "Previous email still marked as unread, do nothing"
'^^I am always getting this outcom when I change selection from an unread email to another email!
End If
'Now identify the status of the newly selected email
For Each objItem In myOlExp.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
End If
Next
If oMail.UnRead Then
Flag = 1 'Means Current selection is an unread email
Else
Flag = 0 'Means Current selection has been read before
End If
Else
' Flag = 0 i.e previous email was already read
' Identify the status of the newly selected item.
For Each objItem In myOlExp.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
End If
Next
If oMail.UnRead Then
Flag = 1
Else
Flag = 0
End If
End If
End Sub
I hope I managed to formulate my question clearly! Any help is most appreciated.
Many Thanks
Once you set Flag = 1, oMail.UnRead status does not matter.
If Flag = 1 Then
' Remove this test
'If oMail.UnRead = False Then
MsgBox "...

Getting "Object variable or With block variable not set" on first use of document.TypeText with Outlook Message

Can anyone help me figure out what's going wrong and how to fix it?
I'm trying to automate sending an email with some daily status information. I'd tried automating this from Access but kept running into (known but apparently unsolved) problems with GetObject(, "Outlook.Application") with Windows 8.1 64 and Outlook 2013. So I decided to automate starting from Outlook.
Anyway, I moved the mail message creation code into Outlook vba and had it start Access and run the Access code. This is all well and good until I get to creating the mail message. Everything starts just fine until it gets to writing to the body of message (using Word as the body editor). At the first "TypeText" command, I'm getting the error message in the title. If I click debug on the error notification dialog and then single-step through the line of code in question, it works just fine. I thought that there was some timing problem, so I stuck a 2-second wait in the code. No luck. The code in question, with some other oddities associated with testing (notably trying to type and then delete text), is below:
Public Sub CreateMetrics()
' Mail-sending variables
Dim mailApp As Outlook.Application
Dim accessApp As Access.Application
Dim mail As MailItem
Dim wEditor As Word.Document
Dim boolCreatedApp As Boolean
Dim i As Integer
Set mailApp = Application
' Create an Access application object and open the database
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase dbLoc
accessApp.Visible = True
' Open the desired form and run the click event hander for the start button
accessApp.DoCmd.OpenForm ("ProcessStatus")
accessApp.Forms![ProcessStatus].StartButton_Click
' Create the outgoing mail message
Set mail = Application.CreateItem(olMailItem)
mail.Display
mail.BodyFormat = olFormatHTML
Set wEditor = mailApp.ActiveInspector.WordEditor
With accessApp.Forms![ProcessStatus]
Debug.Print .lblToList.Caption
Debug.Print .lblSubject.Caption
Debug.Print .lblIntroduction.Caption
Debug.Print .lblAttachFilepath.Caption
End With
mail.To = accessApp.Forms![ProcessStatus].lblToList.Caption
mail.Recipients.ResolveAll
mail.Subject = accessApp.Forms![ProcessStatus].lblSubject.Caption
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
Sleep 2000
' Error occurs in the next line ***********************************************
wEditor.Application.Selection.TypeText Text:="Test"
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.Delete Count:=4
wEditor.Application.Selection.PasteSpecial DataType:=wdPasteBitmap
wEditor.Application.Selection.HomeKey
wEditor.Application.Selection.TypeText accessApp.Forms![ProcessStatus].lblIntroduction.Caption
wEditor.Application.Selection.TypeText Text:=Chr(13) & Chr(13)
wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.EndKey
' wEditor.Application.Selection.TypeText Text:=Chr(13)
' wEditor.Application.Selection.TypeText Text:=configs("EmailSignature")
' End With
With mailApp.Session.Accounts
i = 1
Do While i <= .Count
' Use either the specified email address OR the last outlook email address
If RegEx_IsStringMatching(.Item(i).SmtpAddress, accessApp.Forms![ProcessStatus].lblSenderRegex.Caption) Or i = .Count Then
mail.SendUsingAccount = .Item(i)
i = .Count + 1
Else
i = i + 1
End If
Loop
End With
mail.Save
accessApp.Quit
End Sub
I added a "mail.Display" just before the line that was causing the failure, which seemed, incorrectly, to have fixed the problem.
I have now solved this problem by executing a document.select on the document associated with the email I was creating. To select the right document (there doesn't seem to be any guarantee of which one that would be within the wEditor.Application.Documents collection, though it was typically the first one), I created an almost-certainly unique piece of text and assigned it to the body of the email, which I could then go and find. Here's the new code that I added to the code above:
Dim aDoc As Word.Document
Dim strUniqueID As String
. . .
mail.Attachments.Add accessApp.Forms![ProcessStatus].lblAttachFilepath.Caption
strUniqueID = accessApp.Forms![ProcessStatus].lblSubject.Caption & Rnd(Now()) & Now()
mail.Body = strUniqueID
' Search for the unique text. aDoc.Content has extra characters at the
' end, so compare only for the length of the unique text
For Each aDoc In wEditor.Application.Documents
If Left(aDoc.Content, Len(strUniqueID)) = strUniqueID Then
aDoc.Select
mail.Body = ""
End If
Next aDoc
wEditor.Application.Selection.TypeText Text:="Test"
. . .
I looked at a lot of examples of code that did this kind of thing. None of them performed a select or said anything about needing one. Debugging was made that much harder because the select occured implicitly when the debugger was invoked.

Compare 2 Arrays and if one item of one array is the same exit from loop

Another one question.
I have create a custom form in outlook to assign tasks in users.
All is good until now but i want to do more advance. I have the field To to add recipient and a button Send to send email notification. When someone add a recipient and click in send button send the email notification and save the assigners in a TextBox Multiline separated with vbCrlf.
My problem is that i don't want someone to add a recipient that allready exist in Assigners (TextBox Multiline). I try to compare the two fields without sucess. In this case i have add another one TextBox that get the value of To field when added to compare with the other field that i have it for Assigners.
Find below my code
Sub add_Click()
Set objPage = Item.GetInspector.ModifiedFormPages("Assign Task")
Set objNS = Application.GetNamespace("MAPI")
Set objduedate = objPage.Controls("duedate")
Set objowner = objPage.Controls("owner")
Set objpriority = objPage.Controls("priority")
Set objprogress = objPage.Controls("progress")
Set objstartdate = objPage.Controls("startdate")
Set objpercentcomplete = objPage.Controls("percentcomplete")
Set objassignee= objPage.Controls("assignee")
Set objtest= objPage.Controls("TextBox5")
Dim isFound
strText = objassignee.Value
arrLines = Split(strText, vbCrLf)
strTest=objtest.Value
arrtest = Split(strTest, vbCrLf)
For b=0 to UBound(arrLines)step 1
isFound = False
For i=0 to UBound(arrtest)step 1
if arrtest(i)=arrLines(b) then
msgbox "True"
isFound=True
Exit For
end if
Next
if arrtest(i)<>arrLines(b) then
msgbox "False"
isFound=False
Exit For
end if
Next
End Sub
Any suggestion how can compare the Recipient if it's the same with any of the assigners that i have it in the Assigner field TextBox Multiline?
Instead of handling duplicates by a double for/next loop, you can let a dictionary object do it for you. This is demonstration code, you have to convert it to your specific situation.
option explicit
dim assignees, recipients, assigner, recipient
dim dictAssignees
' Original lists of assigners and recipients:
assignees = "Joe;John;Josh;Jack"
recipients = "Paul;Ringo;John;George"
' Add the assigners to a dictionary
Set dictAssignees = CreateObject("Scripting.Dictionary")
for each assigner in split(assignees, ";")
' The value is only set to True because we have to set it to just something.
' You can set the value to any other boolean, string or object (numbers are converted to strings)
dictAssignees.Item(assigner) = True
next
' Add recipients that are not already in the assignees list to the dictionary
for each recipient in split(recipients, ";")
' You can build duplicate logic like this:
if dictAssignees.exists(recipient) then
msgbox "The recipient " & recipient & " was already present in the assignees list"
end if
' Or just add the items, the dictionary object will handle duplicates
dictAssignees.Item(recipient) = True
next
' Show the list of assignees
msgbox "Assignees: " & join(dictAssignees.Keys, ";")
' Output: "Joe;John;Josh;Jack;Paul;Ringo;George"
Compare the Recipient.Address properties of the two recipients.