Outlook GAL fails to be top-most window when called from VBA UserForm - vba

i have about ten responses from StackOverflow open but none of them quite answer my problem.
i have created several UserForms in Excel VBA for this particular project. (Note: i have no formal training on VBA programming and everything i have done is self-taught or gleaned from copying other people's codes.) While interfacing with more than one of these forms, i want the user to be able to access a command to select a user-name from the company's Global Address List. With a command button on the form and the following function i am able to do this:
Public Function GetUsernameFromOutlook(sCap As String) As String
'fancy code to call Outlook dialog box to select names.
'Badresult is the default, gives username of operator if they try to:
' select more than one recipient
' cancel out of the dialog box
Dim olApp As Object ' Outlook.Application
Dim olDialog As Object ' Outlook.SelectNamesDialog
Dim hwnd As Long
Set olApp = CreateObject("Outlook.Application")
Set olDialog = olApp.Session.GetSelectNamesDialog
With olDialog
.Caption = sCap
.ForceResolution = True
.AllowMultipleSelection = False
.NumberOfRecipientSelectors = olShowTo
.ToLabel = "Select User"
If .Display = False Then GoTo BadResult
SetForegroundWindow (Excel.Application.hwnd)
If .Recipients.Count <> 1 Then GoTo BadResult
'Debug.Print .Recipients(1).Name
'Debug.Print .Recipients(1).Address
'Debug.Print .Recipients(1).AddressEntry.GetExchangeUser.Alias
GetUsernameFromOutlook = .Recipients.Item(1).AddressEntry.GetExchangeUser.Alias
End With
' hwnd = FindWindow(vbNullString, sCap & ": Global Address List")
Set olApp = Nothing
Set olDialog = Nothing
Exit Function
BadResult:
SetForegroundWindow (Excel.Application.hwnd)
GetUsernameFromOutlook = Environ("UserName")
End Function
As you can see i attempted to use the SetForegroundWindow and FindWindow API calls as suggested in other answers. But the code doesn't even reach these lines before causing the problem.
The line If .Display = False brings up the SelectNamesDialog box from Outlook, but because my UserForm is modal (i think), it stays as the visible window. i am forced to use Alt-Tab to switch to Outlook. Then, after either selecting a name or cancelling out of the Outlook dialog box, i need to Alt-Tab again to get back to Excel.
Also, because the code is waiting for a response from the Outlook box, there is no further code execution, so SetForegroundWindow doesn't even happen until i complete all of the Alt-Tab switching.
Other solutions posted have referred to using calls to MSWord, or looking up information from or saving to a spreadsheet. i'm trying to use this call to modify the caption or text of a form control, such as a command button or text box or text label. i only need to collect the Outlook alias, since i have another function which can collect other selected information from Outlook based on the alias, so the alias is saved in a tag (unseen) on the form and converted to full name, initials or e-mail address as needed using this other function.
So far everything works great and i'd really like to release this interface to my beta-testers, but i don't want to have to explain to everyone to use Alt-Tab after they click the "select name" button. They will believe their computer has locked up and do a hard re-start. (Or call IT who will start asking questions that they cannot answer.)
i'm sorry that this question is so long, but i wanted to include as much information as possible. i'm sure there will be things i need to clarify, so please send me your questions in a response and i will do my best to explain better. Thank you for your time.

I just spent an evening on this, so even if this thread is one year old it should help.
You should just try using:
"olApp.ActiveWindow.Activate"
It sums up to this fully working function:
enter Public Function GetUsernameFromOutlook(sCap As String) As String
'fancy code to call Outlook dialog box to select names.
'Badresult is the default, gives username of operator if they try to:
' select more than one recipient
' cancel out of the dialog box
Dim olApp As Outlook.Application ' Outlook.Application
Dim olDialog As Outlook.SelectNamesDialog
Dim hwnd As Long
Set olApp = New Outlook.Application
Set olDialog = olApp.Session.GetSelectNamesDialog
'Set olDialog = new Outlook.Application
With olDialog
.Caption = sCap
'.ForceResolution = True
.AllowMultipleSelection = False
.NumberOfRecipientSelectors = olShowTo
.ToLabel = "Select User"
olApp.ActiveWindow.Activate
.display
If .Recipients.Count <> 1 Then GoTo BadResult
'Debug.Print .Recipients(1).Name
'Debug.Print .Recipients(1).Address
'Debug.Print .Recipients(1).AddressEntry.GetExchangeUser.Alias
GetUsernameFromOutlook = .Recipients.Item(1).AddressEntry
End With
Set olApp = Nothing
Set olDialog = Nothing
Exit Function
BadResult:
GetUsernameFromOutlook = "A voir ultérieurement"
End Function here

Outlook Object Model does not let you specify the parent window of the address book dialog - it will always be Outlook.
On the Extended MAPI level (C++ or Delphi), you can specify the window handle when calling IAddbook::Address, but you cannot do that from VBA.
If using Redemption (I am its author) is an option, you can set the RDOSession.ParentWindow property before using the RDOSelectNames object.
set Session = CreateObject("Redemption.RDOSession")
Session.MAPIOBJECT = Application.Session.MAPIOBJECT
Session.ParentWindow = Excel.Application.hwnd
set ABDialog = Session.GetSelectNamesDialog
ABDialog.Display true

Related

Outlook security prompt: Sendkeys does not have the right focus

I want to automate some basic operations in Outlook 2014, so I create a macro in VBA. But I need to send an email if any error occur during the execution of the script, and I want to bypass the confirmation message of Outlook (the pop up which appeared when you want to send a mail with a macro).
Private Sub sendEmailError()
Dim Email As Outlook.Application
Dim EmailMsg As Outlook.MailItem
Dim Dest As Outlook.Recipient
Set Email = CreateObject("Outlook.Application")
Set EmailMsg = Email.CreateItem(olMailItem)
Set Dest = EmailMsg.Recipients.Add("mail#mail.com")
EmailMsg.Subject = MessageSubject
EmailMsg.Body = MessageBody
EmailMsg.Display
SendKeys "^{ENTER}", True
End Sub
I thought "EmailMsg.Display" would give the focus to the message box and then, thanks to the sendkeys, I could execute the shortcut to send the email. But the focus is not given to the message box, and the control+key shortcut is done in my script after the end of the macro...
Thank you for your help !
You might be able to override the prompt, but kind of by definition you're not supposed to, and my guess is that Microsoft's probably put some security measures to prevent you from doing so. The prompt is meant to make sure that the user is OK with a macro messing with their emails, so it defeats the point to allow macros to just click 'OK' on behalf of the user.
What you can do instead is go into the Outlook Trust Center, and on the Programmatic Access tab, set it to 'Never warn me about suspicious activity'. This will remove the prompt permanently.
I know its not what you aks for, but
EmailMsg.Send
instead of
EmailMsg.Display
would send it right away
With the extra warning Message, it will look like this:
Private Sub sendEmailError()
Dim Email As Outlook.Application
Dim EmailMsg As Outlook.MailItem
Dim Dest As Outlook.Recipient
Set Email = CreateObject("Outlook.Application")
Set EmailMsg = Email.CreateItem(olMailItem)
Set Dest = EmailMsg.Recipients.Add("mail#mail.com")
EmailMsg.Subject = MessageSubject
EmailMsg.Body = MessageBody
EmailMsg.Send
SendKeys " "
End Sub

What VBA method could Outlook trigger as mail is composed or replied?

What I'd need guidance specifically:
To have an indication of a native VBA method available on a new mail compose that would be triggered at any written word / phrase (or as often as possible), or a guidance on how to create an observable of a dynamic form property.
Purpose:
One Outlook functionality that could be interesting to have is to know its readability values as the mail is composed. I know they can be obtained by doing the spell checker, but I'd like to avoid the burden of doing the spellcheck to get the result - I'd like to see numbers going up and down as the mail is written.
Problem:
I kind of created the function I'd need but I failed to find a method that could trigger it at every word written. I'd assume it'd be something like WordEditor_Change, HTMLBody_Change or something alike. It'd be similar to the Worksheet_Change we have in Excel, where values can be obtained as the Excel sheet is edited.
I tried to set an observable of WordEditor.words.count but also failed miserably.
What I have so far:
WithEvents myMail As Outlook.MailItem
Private Sub Application_ItemLoad(ByVal Item As Object)
Set myMail = Item
End Sub
Sub checkStatistics()
Dim objInsp As Outlook.Inspector
Set objInsp = myMail.GetInspector
'Enum Outlook: https://msdn.microsoft.com/es-es/VBA/Outlook-VBA/articles/olobjectclass-enumeration-outlook
If objInsp.EditorType = olEditorWord Then ' outlook 2013
'Doc obj: https://msdn.microsoft.com/en-us/vba/word-vba/articles/document-object-word
Set objdoc = objInsp.WordEditor
Dim var As ClassHandlesEvent
Dim tst As classWithEvent
Set var = New ClassHandlesEvent
Set tst = New classWithEvent
var.EventVariable = tst
tst.value = objdoc.Words.Count
MsgBox objdoc.ReadabilityStatistics(9) & ": " & objdoc.ReadabilityStatistics(9).value & vbCrLf & "(Ideal values above 60)"
MsgBox objdoc.ReadabilityStatistics(8) & ": " & objdoc.ReadabilityStatistics(8).value & vbCrLf & "(Ideal values above 60)"
End If
Set objdoc = Nothing
Set objInsp = Nothing
End Sub
The below code that you execute
Set objdoc = objInsp.WordEditor
Gives you a WordDocument so now you have a WordVBA question instead of a OutlookVBA question. So you want an onchange event on changes to the document
I got lot of threads inside and outside of SO, which confirms that such a event doesn't exists
http://www.vbaexpress.com/forum/showthread.php?15718-Is-there-a-text-change-event-for-Word
Is there a way to trigger "track changes" through VBA in Excel?
Detecting when data is added to a document, eg. a character or white space
http://www.vbaexpress.com/forum/showthread.php?40690-MS-WORD-2k7-Table-content-change-event
So you will need to use what you have now, which is to check the content on email send

Outlook 2013 Userform with block Error when not "Popped Out"

I have a set of macros that have worked in Outlook 2003, 2007, and 2010. In fact, it still works in 2013 except in a specific case.
The macro brings up a dialog box whenever you try to send an email - to tag the subject line with key words. The problem is, if I just started Outlook, and I bring up a new email or reply - the default in Outlook 2013 is to bring it into the former "Reading Pane" rather than in a new window. If I do not hit "Pop Out" and I try to send, my macro crashes with this error:
"Run-time error '91' Object variable or with block variable not set"
I tried to check for loading the form first - but it seem ANY call to my userform, even userform.show, generates this error.
Oddly, if I remember to "Pop Out" my first email, it runs fine everytime after until I close/reopen Outlook. Even if I don't "Pop Out" other emails. It's only on the very first one that this occurs.
Here's the beginning of my Initialize Event:
Dim Tags() As String
Dim T As Variant
Dim PC As Variant
Dim Rent As String
Dim Child As String
Dim nsourcefile As Integer
Dim email As MailItem
Dim PD As Variant
Dim Proj As String
Dim Desc As String
'Set email = Application.ActiveInspector.CurrentItem
Set email = Application.ActiveExplorer.Selection.Item(1)
'Checks to see if a project number (that's not on the list) may be in the subject already
If Val(email.Subject) > 10000 Then
TagMsg.Height = tall
TagMsg.NewProjID = Format(Val(email.Subject), "00000")
TagMsg.NewProjDesc.SetFocus
Else
'Set height of form (prior to pressing "More" button
TagMsg.Height = short
End If
Noticed I changed Set email = Application.ActiveInspector.CurrentItem to Set email = Application.ActiveExplorer.Selection.Item(1). This seems to have fixed it, but the VBA help states "Do not make any assumptions about the Item method return type; your code should be able to handle multiple item types or a ConversationHeader object."
Note that the form is being invoked by the ItemSend event.
First off, putting that code into the Initialize event wasn't a good move. Needed to be moved into a click event where it was actually needed.
Then, I found the code I needed from two other posts, combined and shortened them.
Working with current open email
https://superuser.com/questions/795831/outlook-2013-vba-refer-to-editor-in-reading-pane
Final result
Dim oInspector As Inspector
Dim email As MailItem
Dim oexp As Explorer
Set oInspector = Application.ActiveInspector
Set oexp = Application.ActiveExplorer
If oInspector Is Nothing Then
'Set email = Application.ActiveExplorer.Selection.Item(1)
Set email = oexp.ActiveInlineResponse
If email Is Nothing Then
'MsgBox "No active inspector or inline response"
Exit Sub
End If
Else
Set email = oInspector.CurrentItem
End If 'oInspector is Nothing
If email.Sent Then
'MsgBox "This is not an editable email"
Else
'Checks to see if a project number (that's not on the list) may be in the subject already
If Val(email.Subject) > 10000 Then
TagMsg.Height = tall
TagMsg.NewProjID = Format(Val(email.Subject), "00000")
TagMsg.NewProjDesc.SetFocus
Else
'Set height of form (prior to pressing "More" button
TagMsg.Height = short
End If
End If 'email.sent
Note: This still relies on the fact that it is called by the ItemSend event and the active or current item will be the email I just pressed "send" on.
Thank you, retailcoder for your comments.

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.

Call Outlook procedure using VBScript

I have a procedure in Outlook that sends all the saved messages in Drafts folder.
Below is the code:
Public Sub SendMail()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olDraft As Outlook.MAPIFolder
Dim strfoldername As String
Dim i As Integer
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox)
strfoldername = olFolder.Parent
Set olDraft = olNS.Folders(strfoldername).Folders("Drafts")
If olDraft.Items.Count <> 0 Then
For i = olDraft.Items.Count To 1 Step -1
olDraft.Items.Item(i).Send
Next
End If
End Sub
Above code works fine.
Question:
I want to use Task Scheduler to fire this procedure as a specified time.
1. Where will I put the procedure in Outlook, Module or ThisOutlookSession?
2. I am not good in vbscript so I also don't know how to code it to call the Outlook Procedure. I've done calling Excel Procedure but Outlook doesn't support .Run property.
So this doesn't work:
Dim olApp
Set olApp = CreateObject("Outlook.Application")
olApp.Run "ProcedureName"
Set olApp = Nothing
I've also read about the Session.Logon like this:
Dim olApp
Set olApp = CreateObject("Outlook.Application")
olApp.Session.Logon
olApp.ProcedureName
Set olApp = Nothing
But it throws up error saying object ProcedureName is not supported.
Hope somebody can shed some light.
SOLUTION:
Ok, I've figured out 2 work around to Avoid or get pass this pop-up.
1st one: is as KazJaw Pointed out.
Assuming you have another program (eg. Excel, VBScript) which includes sending of mail via Outlook in the procedure.
Instead of using .Send, just .Save the mail.
It will be saved in the Outlook's Draft folder.
Then using below code, send the draft which fires using Outlook Task Reminder.
Option Explicit
Private WithEvents my_reminder As Outlook.Reminders
Private Sub Application_Reminder(ByVal Item As Object)
Dim myitem As TaskItem
If Item.Class = olTask Then 'This works the same as the next line but i prefer it since it automatically provides you the different item classes.
'If TypeName(Item) = "TaskItem" Then
Set my_reminder = Outlook.Reminders
Set myitem = Item
If myitem.Subject = "Send Draft" Then
Call SendMail
End If
End If
End Sub
Private Sub my_reminder_BeforeReminderShow(Cancel As Boolean)
Cancel = True
Set my_reminder = Nothing
End Sub
Above code fires when Task Reminder shows with a subject "Send Draft".
But, we don't want it showing since the whole point is just to call the SendMail procedure.
So we added a procedure that Cancels the display of reminder which is of olTask class or TaskItem Type.
This requires that Outlook is running of course.
You can keep it running 24 hours as i did or, create a VBscript that opens it to be scheduled via Task Scheduler.
2nd one: is to use API to programatically click on Allow button when the security pop-up appears.
Credits to SiddarthRout for the help.
Here is the LINK which will help you programmatically click on the Allow button.
Of course you have to tweak it a bit.
Tried & Tested!
Assuming that you have Outlook Application always running (according to comment below your question) you can do what you need in the following steps:
add a new task in Outlook, set subject to: "run macro YourMacroName" and set time (plus cycles) when your macro should start.
go to VBA Editor, open ThisOutlookSession module and add the following code inside (plus see the comments inside the code):
Private Sub Application_Reminder(ByVal Item As Object)
If TypeName(Item) = "TaskItem" Then
Dim myItem As TaskItem
Set myItem = Item
If myItem.Subject = "run macro YourMacroName" Then
Call YourMacroName '...your macro name here
End If
End If
End Sub
Where will I put the procedure in Outlook, Module or ThisOutlookSession?
Neither. Paste the below code in a Text File and save it as a .VBS file. Then call this VBS file from the Task Scheduler as shown HERE
Dim olApp, olNS, olFolder, olDraft, strfoldername, i
Set olApp = GetObject(, "Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(6)
strfoldername = olFolder.Parent
Set olDraft = olNS.Folders(strfoldername).Folders("Drafts")
If olDraft.Items.Count <> 0 Then
For i = olDraft.Items.Count To 1 Step -1
olDraft.Items.Item(i).Send
Next
End If
If you are using Outlook 2007 or newer I have found you can easily eliminate the security pop up you mentioned above when running your script by doing the following:
In Outlook 2007 Trust Center, go to Macro Security - Select "No security Check for macros"
In Outlook 2007 Trust Center, go to Programatic Access - Select "Never warn me abous suspicious activity.
Of course that technically leaves you open to the remote possibility for someone to email you some malicious email script or something of that nature I assume. I trust my company has that managed though and this works for me. I can use VBS scripts in Outlook, Access, Excel to send emails with no security pop up.
Another Option:
If you don't want to do that, another option that has worked well for me prior to this is here:
http://www.dimastr.com/redemption/objects.htm
Basically a dll redirect that does not include the popup. It leaves your other default security in place and you write \ call your VBA for it and send mail without the secutity pop-ups.