Ensure MsgBox pops up "on top"

[dpmicka]

I am using a macro to copy a single sheet to a new file, then send that as a Lotus Notes attachment - part of the routine has a message box that comes up asking the user if they want to email the attachment. Sometimes (usually if Notes isn't already open) the msgbox appears, but is hidden behind other open windows. If I click the main Excel title bar (which is flashing - I guess to indicate the msgbox's presence), I see the box and can continue. Is there code that can be inserted to ensure the MsgBox always appears on top???

I'll post my code below (actually it's code I borrowed and pieced together from other board postings) - sorry for it's length. Also, the Session Quit statement doesn't seem to work (won't close out Lotus Notes) - any ideas on that?

Sub SendNotesMail()
Workbooks.Open Filename:="C:\Temp\Lot Summary Attachment.xls"
    Windows("Compactor Import9a.xls").Activate
    Sheets("SUMMARY").Select
    Cells.Select
    Selection.Copy
    Windows("Lot Summary Attachment.xls").Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Windows("Compactor Import9a.xls").Activate
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveSheet.Unprotect Password:="password"
    ActiveSheet.Shapes("Picture 3").Select
    Selection.Copy
    Windows("Lot Summary Attachment.xls").Activate
    Range("G2").Select
    ActiveSheet.Paste
    Selection.ShapeRange.IncrementLeft 2.25
    Selection.ShapeRange.IncrementTop -14.25
    Range("A1").Select
    Windows("Compactor Import9a.xls").Activate
    Range("A1").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="password"
    Windows("Lot Summary Attachment.xls").Activate
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.15)
        .BottomMargin = Application.InchesToPoints(0.15)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 97
    End With
    ActiveWorkbook.Save
    Dim Maildb As Object, MailDoc As Object, AttachMe As Object, Session As Object
Dim UserName As String, MailDbName As String
Dim EmbedObj1 As Object
        
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, _
    (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDataBase(vbNullString, MailDbName)
If Not Maildb.IsOpen Then Maildb.OpenMail
            
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
    ans = MsgBox("Would you like to email a copy of this lot's summary sheet?" _
        , vbQuestion & vbYesNo, "Send Email")
                             
        If ans = vbYes Then
            Recipient = InputBox("Please enter the recipient's email address in the following format: john.doe@xxxx.com" _
                , "Input email address")
        MailDoc.SendTo = Recipient
        End If
MailDoc.Subject = "Compactor Lot Summary"
MailDoc.Body = "Look at this lot:   " & Range("Sheet1!C4").Value
Set AttachMe = MailDoc.CreateRichTextItem("Attachment")
Set EmbedObj1 = AttachMe.Embedobject(1454, vbNullString, _
    "c:\Temp\Lot Summary Attachment.xls", "Attachment")
MailDoc.CreateRichTextItem ("Attachment")
        
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now
        
Call MailDoc.Send(False)
        
'Session.Quit
        
Set EmbedObj1 = Nothing: Set AttachMe = Nothing: Set MailDoc = Nothing
Set Maildb = Nothing: Set Session = Nothing

Windows("Lot Summary Attachment.xls").Activate
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Sheets.Add
ActiveWorkbook.Save
ActiveWorkbook.Close
                
End Sub

 

[bigturnip]

try:
("Would you like to email a copy of this lot's summary sheet?" _
, 65540, "Send Email")

Basically just replace the buttons property with the sum of the values of the constants.

4 = vbYesNo
65536 = VbMsgBoxSetForeground

 

[dpmicka]

That change does produce the msgbox, but it's still not always visible on top (or "in focus" - not sure of best terminology here). Once I click somewhere on the Excel screen, the msgbox appears - was hoping to ensure that it pops up visible every time. Any other thoughts?

 

[Drdave1958]

Not sure, but i think it does that because Excel doesn't have the focus. I don't know if there's a way around that.

-Dave-

 

[dk]

One way might be to put this line just before the msgbox code:-

AppActivate Application.Caption

Does that work for you? If not, there are other (more complex) ways of doing this, but I'll wait to see if that works for you.

 

[dpmicka]

DK... You are the man - that works great! Thanks so much and good luck on that Mad Cow project.

 

[pbornemeier]

An ancient post brought to life, but it still had a good answer.
I am not sure why, but I had to add a DoEvents after the AppActivate line to ensure the message box was always shown.

Sub AutoCloseMsgBox(Optional sText As String, Optional sTitle As String)
    'Message box will be displayed for a set amount of time or until user action is taken
    
    'Adapted from http://www.mrexcel.com/forum/showthread.php?t=20789
    
    If sText = vbNullString Then sText = "Text: Yes, No, or Do Nothing"
    If sTitle = vbNullString Then sTitle = "Title"
    
    Const WaitTime As Integer = 5
    
    Const btnOK As Integer = 0
    Const btnOKCancel As Integer = 1
    Const btnAbReIg As Integer = 2
    Const btnYesNoCancel As Integer = 3
    Const btnYesNo As Integer = 4
    Const btnReCancel As Integer = 5
    
    Const iconStop As Integer = 16 'Show "Stop Mark" icon.
    Const iconQ As Integer = 32    'Show "Question Mark" icon.
    Const iconExc As Integer = 48  'Show "Exclamation Mark" icon.
    Const iconInfo As Integer = 64 'Show "Information Mark" icon.
    
    Dim WshShell, RetValue
    Set WshShell = CreateObject("WScript.Shell")
    
    RetValue = WshShell.Popup(sText, WaitTime, _
        sTitle, btnYesNo + iconInfo)
    '// Valid Return values
    '1 = OK Button, 2 = Cancel Button, 3 = Abort Button, 4 = Retry Button
    '5 = Ignore Button, 6 = Yes Button, 7 = No Button
    
    AppActivate Application.Caption
    DoEvents
    
    Select Case RetValue
       Case 6   'Yes
            MsgBox "Yes"
       Case 7   'No
            MsgBox "No"
       Case -1  'No Selection
            MsgBox "No Selection"
    End Select

End Sub