I'm using the WshShell.popup as an alternative to msgbox. It offers a wait time functionality, which is suppose to be in seconds...but if I put in 2, the message box stays up for about 5-6 seconds. Any ideas?
more info:
http://msdn.microsoft.com/en-us/library/x83z1d9f(v=vs.85).aspx
Here is the code I wrote...Feel free to use it - it works great - except for wait time...I need some help figuring the timing issue out.
called from a regular module:
function is in a different regular module:
in class module ClaMyMessages:
more info:
http://msdn.microsoft.com/en-us/library/x83z1d9f(v=vs.85).aspx
Here is the code I wrote...Feel free to use it - it works great - except for wait time...I need some help figuring the timing issue out.
called from a regular module:
Code:
Sub testmymsgbox()
Dim intTstReply As Integer
intTstReply = MyMsgBox("Test", "btnOKCancel+btnQuestion", "TheTester", 2)
Select Case intTstReply
'1 = OK Button, 2 = Cancel Button, 3 = Abort Button, 4 = Retry Button _
5 = Ignore Button, 6 = Yes Button, 7 = No Button
Case 1
MyMsgBox "You pressed OK"
Case 2
MyMsgBox "You pressed Cancel"
Case 3
MyMsgBox "You pressed Abort"
Case 4
MyMsgBox "You pressed Retry"
Case 5
MyMsgBox "You pressed Ignore"
Case 6
MyMsgBox "You pressed Yes"
Case 7
MyMsgBox "You pressed No"
Case 0
MyMsgBox "You timed out"
End Select
End Sub
Code:
Option Explicit
Option Explicit
Function MyMsgBox(Prompt As String, Optional Buttons As String, Optional Title As String, Optional WaitTime As Long)
Dim oMsg As ClaMyMessages
Dim intRet As Integer
Set oMsg = New ClaMyMessages
With oMsg
.MyBox Prompt, Buttons, Title, WaitTime
MyMsgBox = .ButtonValue
End With
Set oMsg = Nothing
'1 = OK Button, 2 = Cancel Button, 3 = Abort Button, 4 = Retry Button _
5 = Ignore Button, 6 = Yes Button, 7 = No Button
End Function
Code:
Option Explicit
Private intRV As Integer
Public Property Get ButtonValue() As Integer
ButtonValue = Returned
End Property
Private Property Get Returned() As Integer
Returned = intRV
End Property
Private Property Let Returned(value As Integer)
intRV = value
End Property
Sub MyBox(Prompt As String, Optional Buttons As String, Optional Title As String, Optional WaitTime As Long)
Dim WshShell As Object
Dim intRet As Integer
Set WshShell = CreateObject("WScript.Shell")
intRet = WshShell.Popup(Prompt, WaitTime, Title, ButtonNumbers(Buttons))
'1 = OK Button, 2 = Cancel Button, 3 = Abort Button, 4 = Retry Button _
5 = Ignore Button, 6 = Yes Button, 7 = No Button
Returned = intRet
End Sub
Private Function ButtonNumbers(Buttons As String) As Integer
Dim str(1 To 100) As String
Dim intButtons As Integer
Dim intBtn As Integer
Dim intC As Integer
Dim intP As Integer
Dim intL As Integer
Dim intX As Integer
str(1) = Replace(Buttons, " ", "")
intX = 1
intC = 0
Do
intBtn = 0
intC = intC + intL
intL = 0
intP = 0
If intX < 2 Then intX = 2 Else intX = intX + 1
If intX = 2 Then
intL = InStr(1, str(1), "+") '- 1
Else
intP = InStr(intC + 1, str(1), "+") - Len(str(intX - 1))
If intP < 0 Then intP = 0
intL = Len(str(1)) - intC - intP
End If
If intL <= 0 Then intL = Len(str(intX - 1))
str(intX) = Replace(Trim(Mid(str(1), intC + 1, intL)), "+", "")
If Not intX = 2 And str(intX) = vbNullString Then Exit Do
If Not IsNumeric(str(intX)) Then
Select Case str(intX)
Case "btnOK"
intBtn = 0
Case "btnOKCancel"
intBtn = 1
Case "btnAbortRetryIgnore"
intBtn = 2
Case "btnYesNoCancel"
intBtn = 3
Case "btnYesNo"
intBtn = 4
Case "btnRetryCancel"
intBtn = 5
' Icon constants
Case "btnCritical"
intBtn = 16
Case "btnQuestion"
intBtn = 32
Case "btnExclamation"
intBtn = 48
Case "btnInformation"
intBtn = 64
' Button defaults
Case "btnDefault1"
intBtn = 0
Case "btnDefault2"
intBtn = 256
Case "btnDefault3"
intBtn = 512
Case "btnDefault4"
intBtn = 768
Case "btnAppModal"
intBtn = 0 ' Application modal
Case "btnSysModal"
intBtn = 4096 'System modal
Case "btnHelp"
intBtn = 16384 'Adds Help button to the message box
Case "btnMsgForegrnd"
intBtn = 65536 'Specifies the message box window as the foreground window
Case "btnTextRight"
intBtn = 524288 'Text is right aligned - use with setting below
Case "btnRightLeft"
intBtn = 1048576 'Specifies text should appear as right-to-left for reading on Hebrew and Arabic systems
Case Else
intBtn = -100
End Select
If intBtn = -100 Then Exit Do
If intButtons = 0 Then
intButtons = intBtn
Else
intButtons = intButtons + intBtn
End If
Else
If intButtons = 0 Then
intButtons = str(intX)
Else
intButtons = intButtons + str(intX)
End If
End If
Loop
ButtonNumbers = intButtons
End Function
