Related
What I'm trying to do:
I'm trying to copy text to the clipboard then paste into excel while keeping all the formatting.
The only way I have found to stop excel from spreading the text across many cells and keep formatting like bullet points etc is after copying to the clipboard, to paste it directly into the formula bar.
How I'm attempting it:
I'm using Win API to get the handle of the formula bar.
Then sending a WM_PASTE message to the window to paste what's on the clipboard.
Then sending a WM_SETFOCUS message to the window ready to receive the return key.
Then sending a WM_KEYDOWN message for the return key.
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx _
Lib "user32" _
Alias "FindWindowExA" _
(ByVal hwndParent As Long, _
ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, _
ByVal lpszWindow As String) As Long
Private Declare Function SendMessage _
Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) _
As Long
Declare Function PostMessage _
Lib "user32" _
Alias "PostMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Declare Function SetForegroundWindow _
Lib "user32" _
(ByVal hWnd As Long) As Long
Private Const WM_CUT As Long = &H300
Private Const WM_COPY As Long = &H301
Private Const WM_PASTE As Long = &H302
Private Const WM_CLEAR As Long = &H303
Private Const WM_UNDO As Long = &H304
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_F5 As Long = &H74
Private Const VK_RETURN As Long = &HD
Private Const WM_CHAR As Long = &H102
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Const WM_IME_SETCONTEXT As Long = &H281
Public Sub pasteClipboard()
hwndMain = Application.hWnd: Debug.Print hwndMain
hwndFormulaBar = FindWindowEx(Application.hWnd, ByVal 0&, "EXCEL<", vbNullString): Debug.Print hwndFormulaBar
hwndDesk = FindWindowEx(Application.hWnd, ByVal 0&, "XLDESK", vbNullString): Debug.Print hwndDesk
hwndSheet = FindWindowEx(hwndDesk, ByVal 0&, "EXCEL7", vbNullString): Debug.Print hwndSheet
RetVal = SendMessage(hwndFormulaBar, WM_PASTE, 0, ByVal 0)
Debug.Print SendMessage(hwndFormulaBar, WM_SETFOCUS, 0, 0)
Debug.Print SendMessage(hwndFormulaBar, WM_IME_SETCONTEXT, &H0, &H0)
Debug.Print SendMessage(hwndFormulaBar, WM_KEYDOWN, VK_RETURN, &H0)
End Sub
The Problem:
This all works up until when I send the return key to finish editing the cell which is what I'd like to happen. Instead it puts a carriage return in the text box which makes a lot of sense but not the result I wanted.
I've looked at the formula window with Spy++ and watched what happens when I type something in the window and hit return - when the return key is hit it finishes editing the cell.
The only two commands I'm not using that show up in Spy++ are WM_IME_SETCONTEXT and WM_IME_NOTIFY but in all honesty I'm not sure what these two commands do.
I tried using the WM_IME_SETCONTEXT above thinking I may have to change it before sending the return key but the results didn't change.
Any solutions?
If anyone can point me in the right direction of how to send a message that will finish editing the cell (doesn't have to be the return key, that was just my first thought) that would be great.
Many Thanks
Thank you for all the comments.
#Rita Han - MSFT The application.SendKeys worked as long as the focus was not the VBE window which is great!
Problem Statement
In VBA, three main kinds of date time controls can be used provided certain ocxs have been registered using administrator rights. These are VB6 controls and are not native to VBA environment. To install the Montview Control and Datetime Picker, we need to set a reference to Microsoft MonthView Control 6.0 (SP4) which can only be accessed by elevated registration of mscomct2.ocx. Similarly for mscal.ocx and mscomctl.ocx. Having said that, the deprecated mscal.ocx may or may not work on Windows 10.
Depending on your Windows and Office versions (32 bit or 64 bit), it can be really painful to register these ocxs.
The Monthview Control, Datetime Picker and the deprecated Calendar control look like below.
So what problem can I face if I include these in my applicaiton?
If you include them in your project and distribute them to your friends, neighbours, clients etc the application may or may not work depending on whether they have those ocx installed.
And hence it is highly advisable NOT to use them in your project
What alternative(s) do I have?
This calendar, using Userform and Worksheet, was suggested earlier and is incredibly basic.
When I saw the Windows 10 calendar which popped up when I clicked on the date and time from the system tray, I could not help but wonder if we can replicate that in VBA.
This post is about how to create a calendar widget which is not dependant on any ocx or 32bit/64bit and can be freely distributed with your project.
This is what the calendar looks like in Windows 10:
and this is how you interact with it:
The sample file (added at the end of the post) has a Userform, Module and a Class Module. To incorporate this into your project, simply export the Userform, Module and the Class Module from the sample file and import it into your project.
Class Module Code
In the Class Module (Let's call it CalendarClass) paste this code
Public WithEvents CommandButtonEvents As MSForms.CommandButton
'~~> Unload the form when the user presses Escape
Private Sub CommandButtonEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If Not f Is Nothing Then If KeyAscii = 27 Then Unload f
End Sub
'~~> This section delas with showing/displaying controls
'~~> and updating different labels
Private Sub CommandButtonEvents_Click()
f.Label6.Caption = CommandButtonEvents.Tag
If Left(CommandButtonEvents.Name, 1) = "Y" Then
If Len(Trim(CommandButtonEvents.Caption)) <> 0 Then
CurYear = Val(CommandButtonEvents.Caption)
With f
.HideAllControls
.ShowMonthControls
.Label4.Caption = CurYear
.Label5.Caption = 2
.CommandButton1.Visible = False
.CommandButton2.Visible = False
End With
End If
ElseIf Left(CommandButtonEvents.Name, 1) = "M" Then
Select Case UCase(CommandButtonEvents.Caption)
Case "JAN": CurMonth = 1
Case "FEB": CurMonth = 2
Case "MAR": CurMonth = 3
Case "APR": CurMonth = 4
Case "MAY": CurMonth = 5
Case "JUN": CurMonth = 6
Case "JUL": CurMonth = 7
Case "AUG": CurMonth = 8
Case "SEP": CurMonth = 9
Case "OCT": CurMonth = 10
Case "NOV": CurMonth = 11
Case "DEC": CurMonth = 12
End Select
f.HideAllControls
f.ShowSpecificMonth
End If
End Sub
Module Code
In the Module (Let's call it CalendarModule) paste this code
Option Explicit
Public Const GWL_STYLE = -16
Public Const WS_CAPTION = &HC00000
#If VBA7 Then
#If Win64 Then
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
"GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias _
"SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#Else
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare Function SetWindowLongPtr Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#End If
Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
(ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
Public TimerID As LongPtr
Dim lngWindow As LongPtr, lFrmHdl As LongPtr
#Else
Public Declare Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar _
Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function FindWindowA _
Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare Function SetTimer Lib "user32" ( _
ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long
Dim lngWindow As Long, lFrmHdl As Long
#End If
Public TimerSeconds As Single, tim As Boolean
Public CurMonth As Integer, CurYear As Integer
Public frmYr As Integer, ToYr As Integer
Public f As frmCalendar
Enum CalendarThemes
Venom = 0
MartianRed = 1
ArcticBlue = 2
Greyscale = 3
End Enum
Sub Launch()
Set f = frmCalendar
With f
.Caltheme = Greyscale
.LongDateFormat = "dddd dd. mmmm yyyy" '"dddd mmmm dd, yyyy" etc
.ShortDateFormat = "dd/mm/yyyy" '"mm/dd/yyyy" or "d/m/y" etc
.Show
End With
End Sub
'~~> Hide the title bar of the userform
Sub HideTitleBar(frm As Object)
#If VBA7 Then
Dim lngWindow As LongPtr, lFrmHdl As LongPtr
lFrmHdl = FindWindow(vbNullString, frm.Caption)
lngWindow = GetWindowLongPtr(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLongPtr(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
#Else
Dim lngWindow As Long, lFrmHdl As Long
lFrmHdl = FindWindow(vbNullString, frm.Caption)
lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
#End If
End Sub
'~~> Start Timer
Sub StartTimer()
'~~ Set the timer for 1 second
TimerSeconds = 1
TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub
'~~> End Timer
Sub EndTimer()
On Error Resume Next
KillTimer 0&, TimerID
End Sub
'~~> Update Time
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows ' Use LongLong and LongPtr
Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As LongLong, _
ByVal nIDEvent As LongPtr, ByVal dwTimer As LongLong)
frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
End Sub
#Else ' 32 bit Excel
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal nIDEvent As Long, ByVal dwTimer As Long)
frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
End Sub
#End If
'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
' Purpose: get weekday in "DDD" format
wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd") ' the first day in year 1906 starts with a Sunday
End Function
'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
' Example call: mon(12, "1031") or mon(12, "de")
mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function
'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(3) International patterns
Function cPattern(ByVal ctry As String) As String
' Purpose: return country code pattern for above functions mon() and wday()
' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx
ctry = LCase(Trim(ctry))
Select Case ctry
Case "1033", "en-us": cPattern = "[$-409]" ' English (US)
Case "1031", "de": cPattern = "[$-C07]" ' German
Case "1034", "es": cPattern = "[$-C0A]" ' Spanish
Case "1036", "fr": cPattern = "[$-80C]" ' French
Case "1040", "it": cPattern = "[$-410]" ' Italian
' more ...
End Select
End Function
Userform Code
The Userform (Let's call it frmCalendar) code is too big to be posted here. Please refer to the sample file.
Screenshot
Themes
Highlights
No need to register any dll/ocx.
Easily distributable. It is FREE.
No Administratior Rights required to use this.
You can select a skin for the calendar widget. One can choose from 4 themes Venom, MartianRed, ArticBlue and GreyScale.
Choose Language to see Month/Day name. Support for 4 languages.
Specify Long and Short date formats
Sample File
Sample File
Acknowlegements #Pᴇʜ, #chrisneilsen and #T.M. for suggesting improvements.
What's New:
Bugs reported by #RobinAipperspach and #Jose fixed
This is my first post here. I felt compelled to share as the loss of the calendar in Excel was a huge deal and this calendar SiddhartRout created is incredible. So, MANY thanks to #SiddhartRout for putting together this really amazing calendar. I made changes to the cosmetics but most of the underlying meat of it is still all Siddhart's work with some minor changes to meet my use case.
Cosmetic changes:
Replaced ALL of the buttons with borderless labels so it looks a lot more like the Windows 10 calendar
The border of the labels will appear/disappear on mouse enter/exit
I grayed out days that aren't for the current month. The 'gray out' is a different color that matches better for each theme.
Modified the theme colors to my liking. Added a label to click for cycling through the themes.
Changed the font to Calibri
added color change on mouse entry to month/year and arrow controls
Use this site for all of you color code needs --> RGB Color Codes
Code Changes
Optimized the Property Let Caltheme making it easier to setup and add theme colors or entirely new themes
I couldn't get the 'ESC to exit' to work reliably so i replaced it with an 'X'. It stopped crashing as much as well.
Removed the localization stuff as i'll never need it
Changing from buttons to labels required modifying some object variables where needed throughout the project
Added public variables used to store RGB values allowing use of theme colors throughout the project providing for more consistent and easier application of selected theme
User selected theme stored in the hidden sheet so it's persistent between runs
Removed the checkmark button & launch directly from a click on any day.
Screenshots of each theme:
Download link for code:
Win10ExcelCal.xlsm
Get international day & month names
This answer is intended to be helpful to Sid's approach regarding internationalization; so it doesn't repeat the other code parts which I consider to be clear enough building a UserForm. If wanted, I can delete it after incorporation in Vers. 4.0.
Just in addition to Sid's valid solution I demonstrate a simplified code to get international weekday and month names
- c.f. Dynamically display weekday names in native Excel language
Modified ChangeLanguage procedure in form's module frmCalendar
Sub ChangeLanguage(ByVal LCID As Long)
Dim i&
'~~> Week Day Name
For i = 1 To 7
Me.Controls("WD" & i).Caption = Left(wday(i, LCID), 2)
Next i
'~~> Month Name
For i = 1 To 12
Me.Controls("M" & i).Caption = Left(mon(i, LCID), 3)
Next i
End Sub
Called Functions in CalendarModule
These three functions could replace the LanguageTranslations() function.
Advantage: short code, less memory, easier maintenance, correct names
'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
' Purpose: get weekday in "DDD" format
wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd") ' the first day in year 1906 starts with a Sunday
End Function
'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
' Example call: mon(12, "1031") or mon(12, "de")
mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function
'(3) International patterns
Function cPattern(ByVal ctry As String) As String
' Purpose: return country code pattern for above functions mon() and wday()
' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx
ctry = lcase(trim(ctry))
Select Case ctry
Case "1033", "en-us"
cPattern = "[$-409]" ' English (US)
Case "1031", "de"
cPattern = "[$-C07]" ' German
Case "1034", "es"
cPattern = "[$-C0A]" ' Spanish
Case "1036", "fr"
cPattern = "[$-80C]" ' French
Case "1040", "it"
cPattern = "[$-410]" ' Italian
' more ...
End Select
End Function
I have checked related questions such as this or this one but the solutions there do not seem to solve my problem.
I am running a VBA script on my computer. The script takes a few minutes to execute and while waiting I am checking other things in my computer. To get my attention once the script has finished running, I have included a MsgBox at the end of my script. However, because Excel is not active/selected when the script finishes, I cannot see it - only when I reactivate/select Excel.
How can I bring into focus the MsgBox when Excel is not active? I have already tried the following tweaks but they do not work:
ThisWorkbook.Activate:
...
ThisWorkbook.Activate
MsgBox "..."
...
AppActivate() (this command threw an error):
...
AppActivate("Microsoft excel")
MsgBox "..."
...
How about playing a sound when the program finishes?
Place this declaration at the top of a standard code module, above any procedures existing there.
Public Declare Function Beep Lib "kernel32" _
(ByVal dwFreq As Long, _
ByVal dwDuration As Long) As Long
If you place this procedure in the same module you may not need it to be public. Adjust pitch and duration to your preference.
Sub EndSound()
Beep 500, 1000
End Sub
Then place the procedure call at the end of your program.
Call EndSound
I suppose you might use a more elaborate sound - may I suggest a couple of bars from Beethoven's 5th? Modify the EndSound procedure. Chip Pearson has more on this idea.
Try:
Application.WindowState = xlMaximized
Disclaimer: This is not my code and I do not know who the author is. I had this code in my database.
Put your code in Sub Sample(). I have shown where you can insert your code. Once the code is run, Excel will flash 5 times. you can change this number by changing Private Const NumberOfFlashes = 5
Paste this in a Module.
Option Explicit
Private Type FLASHWINFO
cbSize As Long
Hwnd As Long
dwFlags As Long
uCount As Long
dwTimeout As Long
End Type
Private Const FLASHW_STOP As Long = 0
Private Const FLASHW_CAPTION As Long = &H1
Private Const FLASHW_TRAY As Long = &H2
Private Const FLASHW_ALL As Long = (FLASHW_CAPTION Or FLASHW_TRAY)
Private Const FLASHW_TIMER As Long = &H4
Private Const FLASHW_TIMERNOFG As Long = &HC
Private FLASHW_FLAGS As Long
Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long
Private Declare Function FlashWindowEx Lib "user32" _
(FWInfo As FLASHWINFO) As Boolean
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Const NumberOfFlashes = 5
Private Function APIFunctionPresent(ByVal FunctionName _
As String, ByVal DllName As String) As Boolean
Dim lHandle As Long
Dim lAddr As Long
lHandle = LoadLibrary(DllName)
If lHandle <> 0 Then
lAddr = GetProcAddress(lHandle, FunctionName)
FreeLibrary lHandle
End If
APIFunctionPresent = (lAddr <> 0)
End Function
Sub Sample()
'
' Put your code here. Once that code finishes, Excel will FLASH
'
Dim udtFWInfo As FLASHWINFO
If Not APIFunctionPresent("FlashWindowEx", "user32") Then Exit Sub
With udtFWInfo
.cbSize = Len(udtFWInfo)
.Hwnd = Application.Hwnd
.dwFlags = FLASHW_FLAGS Or FLASHW_TRAY
.uCount = NumberOfFlashes
.dwTimeout = 0
End With
Call FlashWindowEx(udtFWInfo)
MsgBox "Done"
End Sub
The easiest way is to probably to create a userform instead then set the focus to this when it initialises.
Code in the userform to show as modal:
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName _
As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Sub UserForm_Initialize()
Dim hwnd As Long: hwnd = FindWindow(vbNullString, Me.Caption)
If hwnd > 0 Then SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS ' Set Modal
End Sub
I have the following code declared:
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
And i have a function to access it as follows:
Private Function ReadIniFileString(ByVal Sect As String, ByVal Keyname As String) As String
Dim Worked As Long
Dim RetStr As String * 128
Dim StrSize As Long
Dim iNoOfCharInIni As Long
Dim sIniString As String
Dim sProfileString As String
iNoOfCharInIni = 0
sIniString = ""
If Sect = "" Or Keyname = "" Then
MsgBox "Section Or Key To Read Not Specified !!!", vbExclamation, "INI"
Else
sProfileString = ""
RetStr = Space(128)
StrSize = Len(RetStr)
Worked = GetPrivateProfileString(Sect, Keyname, "", RetStr, StrSize, IniFileName)
If Worked Then
iNoOfCharInIni = Worked
sIniString = Left$(RetStr, Worked)
End If
End If
ReadIniFileString = sIniString
End Function
This works under 2007, but i get an error on Excel 2010 at the:
Worked = GetPrivateProfileString(Sect, Keyname, "", RetStr, StrSize, IniFileName)
i get an "Can't find sub or function error" I have seen on the web that i should be able to fix this via declaring the function at PtrSafe, and returning a LongPtr. I've done that but get the same results!
Any help please!
Thanks so much!
Russ
To make this work in a 64 bit version of Excell you need to add the PtrSafe Attribute to the function Declaration like so:
Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" Alias...
You don't say whether Excel 2010 is 32 bits or 64. I'm not sure what would happen if a VBA module running in a 64 bit instance of Excel would do if it tried to call a 32 bit routine, and kernel32.dll is a 32 bit library. Since GetPrivatePorfileString is deprecated, I suspect it didn't get ported to the 64 bit counterpart of kernel32.dll.
This is the correct code. I hope works!
Private Declare PtrSafe Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" ( _
ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
The question comes from code like this.
Set scriptshell = CreateObject("wscript.shell")
Const TIMEOUT_IN_SECS = 60
Select Case scriptshell.popup("Yes or No? leaving this window for 1 min is the same as clicking Yes.", TIMEOUT_IN_SECS, "popup window", vbYesNo + vbQuestion)
Case vbYes
Call MethodFoo
Case -1
Call MethodFoo
End Select
This is a simple way to display a message box with a timeout from VBA (or VB6).
In Excel 2007 (apparently also happens in Internet Explorer at times) the popup window will not timeout, and instead wait for user input.
This issue is tough to debug as it only happens occasionally and I do not know the steps to reproduce the issue. I believe it to be an issue with Office modal dialogs and Excel not recognising the timeout has expired.
See http://social.technet.microsoft.com/Forums/en-US/ITCG/thread/251143a6-e4ea-4359-b821-34877ddf91fb/
The workarounds I found are:
A. Use a Win32 API call
Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Sub MsgBoxDelay()
Const cmsg As String = "Yes or No? leaving this window for 1 min is the same as clicking Yes."
Const cTitle As String = "popup window"
Dim retval As Long
retval = MessageBoxTimeout(FindWindow(vbNullString, Title), cmsg, cTitle, 4, 0, 60000)
If retval <> 7 Then
Call MethodFoo
End If
End Sub
B. Use a manual timer with a VBA userform that is designed to look like a messagebox. Use a global variable or similar to save any state that needs to be passed back to the calling code. Ensure that the Show method of the userform is called with the vbModeless parameter supplied.
C. Wrap the call to wscript.popup method in the MSHTA process which would allow the code to run out of process and avoid the modal nature of Office.
CreateObject("WScript.Shell").Run "mshta.exe vbscript:close(CreateObject(""WScript.Shell"").Popup(""Test"",2,""Real%20Time%20Status%20Message""))"
What is the best way of A, B or C or your own answer to display a message box with a timeout value in VBA?
This is a long answer, but there's a lot of ground to cover: it's also a late reply, but things have changed since some of the replies to this (and similar questions) have been posted on the stack. That sucks like a vacuum cleaner on triple-phase AC, because they were good answers when they were posted and a lot of thought went into them.
The short version is: I noticed that the Script WsShell Popup solution stopped working for me in VBA a year ago, and I coded a working API timer callback for the VBA MsgBox function.
Skip straight to the code under the heading VBA code to call a Message Box with a Timeout if you need an answer in a hurry - and I did, I have literally thousands of instances of a self-dismissing 'MsgPopup' substitute for VBA.MsgBox to redact, and the code below fits into a self-contained module.
However, the VBA coders here - myself included - need some explanation as to why perfectly good code no longer seems to work. And if you understand the reasons, you may be able to use the partial workaround for 'Cancel' dialogs, buried in the text.
I noticed that the Script WsShell Popup solution stopped working for me in VBA a year ago - The 'SecondsToWait' timeout was being ignored, and the dialog just hung around like the familiar VBA.MsgBox:
MsgPopup = objWShell.PopUp(Prompt, SecondsToWait, Title, Buttons)
And I think I know the reason why: you can no longer send a WM_CLOSE or WM_QUIT message to a dialog window from anywhere other than the thread which opened it. Likewise, the User32 DestroyWindow() function will not close a dialog window unless it's called by the thread that opened the dialog.
Someone in Redmond doesn't like the idea of a script running in the background and sending a WM_CLOSE commands to all those essential warnings that halt your work (and, these days, making them go away permanently needs local admin privileges).
I can't imagine who would write a script like that, it's a terrible idea!
There are consequences and collateral damage to that decision: WsScript.Popup() objects in the single-threaded VBA environment implement their 'SecondsToWait' timeout using a Timer callback, and that callback sends a WM_CLOSE message, or something like it... Which is ignored in most cases, because it's a callback thread, not the owner thread for the dialog.
You might get it to work on a popup with a 'CANCEL' button, and it'll become clear why that is in a minute or two.
I've tried writing a timer callback to WM_CLOSE the popup, and that failed for me, too, in most cases.
I've tried some exotic API callbacks to mess with the VBA.MsgBox and WsShell.Popup window, and I can tell you now that that they didn't work. You can't work with what isn't there: those dialog windows are very simple and most of them don't contain any functionality, at all, except for the responses in the button clicks - Yes, No, OK, Cancel, Abort, Retry, Ignore, and Help.
'Cancel' is an interesting one: it appears that you get a freebie from the primitive Windows API for built-in dialogs when you specify vbOKCancel or vbRetryCancel or vbYesNoCancel - the 'Cancel' function is automatically implemented with a 'close' button in the dialog's Menu bar (you don't get that with the other buttons, but feel free to try it with a dialog containing 'Ignore'), which means that....WsShell.Popup() dialogs will sometimes respond to the SecondsToWait timeout if they have a 'Cancel' option.
objWShell.PopUp("Test Me", 10, "Dialog Test", vbQuestion + vbOkCancel)
That might be a good enough workaround for someone reading this, if all you wanted was to get WsShell.Popup() functions to respond to the SecondsToWait parameter again.
This also means that you can send WM_CLOSE messages to the 'Cancel' dialog using the SendMessage() API call on a callback:
SendMessage(hwndDlgBox, WM_CLOSE, ByVal 0&, ByVal 0&)
Strictly speaking, this should only work for the WM_SYSCOMMAND, SC_CLOSE message - the 'close' box in the command bar is a 'system' menu with a special class of commands but, like I said, we're getting freebies from the Windows API.
I got that to work, and I started thinking: If I can only work with what's there, maybe I'd better find out what's actually there...
And the answer turns out to be obvious: Dialog boxes have their own set of WM_COMMAND message parameters -
' Dialog window message parameters, replicating Enum vbMsgBoxResult:
CONST dlgOK As Long = 1
CONST dlgCANCEL As Long = 2
CONST dlgABORT As Long = 3
CONST dlgRETRY As Long = 4
CONST dlgIGNORE As Long = 5
CONST dlgYES As Long = 6
CONST dlgNO As Long = 7
And, as these are the 'user' messages which return the user responses to the caller (that is to say, the calling thread) of the dialog, the dialog box is happy to accept them and close itself.
You can interrogate a dialog window to see if it implements a particular command and, if it does, you can send that command:
If GetDlgItem(hWndMsgBox, vbRetry) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, vbRetry, 0&
Exit For
End If
The remaining challenge is to detect a 'Timeout' and intercept the returning Message Box response, and substitute our own value: -1 if we're following the convention established by the WsShell.Popup() function. So our 'msgPopup' wrapper for a Message Box with a timeout needs to do three things:
Call our API Timer for the delayed dismissal of the dialog;
Open the message Box, passing in the usual parameters;
Either: Detect a timeout and substitute the 'timeout' response...
...Or return the user response to the dialog, if they responded in
time
Elsewhere, we need to declare the API calls for all this, and we absolutely must have a Publicly-declared 'TimerProc' function for the Timer API to call. That function has to exist, and it has to run to 'End Function' without errors or breakpoints - any interruption, and the API Timer() will call down the wrath of the operating system.
VBA code to call a Message Box with a Timeout:
Option Explicit
Option Private Module
' Nigel Heffernan January 2016
' Modified from code published by Microsoft on MSDN, and on StackOverflow: this code is in ' the public domain.
' This module implements a message box with a 'timeout'
' It is similar to implementations of the WsShell.Popup() that use a VB.MessageBox interface
' with an additional 'SecondsToWait' or 'Timeout' parameter.
Private m_strCaption As String
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT 'cancel', nor the default button choice.
Dim TimerStart As Single
If Title = "" Then
Title = ThisWorkbook.Name
End If
If SecondsToWait > 0 Then
' TimedmessageBox launches a callback to close the MsgBox dialog
TimedMessageBox Title, SecondsToWait
TimerStart = VBA.Timer
End If
MsgPopup = MsgBox(Prompt, Buttons, Title)
If SecondsToWait > 0 Then
' Catch the timeout, substitute -1 as the response
If (VBA.Timer - TimerStart) >= SecondsToWait Then
MsgPopup = -1
End If
End If
End Function
Public Function MsgBoxResultText(ByVal MsgBoxResult As VbMsgBoxResult) As String
' Returns a text value for the integers returned by VBA MsgBox() and WsShell.Popup() dialogs
' Additional value: 'TIMEOUT', returned when the MsgBoxResult = -1 ' All other values return the string 'ERROR'
On Error Resume Next
If (MsgBoxResult >= vbOK) And (MsgBoxResult <= vbNo) Then
MsgBoxResultText = Split("ERROR,OK,CANCEL,ABORT,RETRY,IGNORE,YES,NO,", ",")(MsgBoxResult)
ElseIf MsgBoxResult = dlgTIMEOUT Then
MsgBoxResultText = "TIMEOUT"
Else
MsgBoxResultText = "ERROR"
End If
End Function
'
'
'
'
'
'
'
'
'
'
Private Property Get MessageBox_Caption() As String
MessageBox_Caption = m_strCaption
End Property
Private Property Let MessageBox_Caption(NewCaption As String)
m_strCaption = NewCaption
End Property
Private Sub TimedMessageBox(Caption As String, Seconds As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' Public Sub TimerProcMessageBox MUST EXIST
MessageBox_Caption = Caption
SetTimer 0&, 0&, Seconds * 1000, AddressOf TimerProcMessageBox
Debug.Print "start Timer " & Now
End Sub
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows
' Use LongLong and LongPtr
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As LongLong)
On Error Resume Next
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
' Closes a dialog box (Shell.Popup or VBA.MsgBox) having a caption stored in MessageBox_Caption
' This TimerProc sends *any* message that can close the dialog: the objective is solely to close
' the dialog and resume the VBA thread. Your caller must detect the expired TimerProc interval
' and insert a custom return value (or default) that signals the 'Timeout' for responses.
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
KillTimer hWndMsgBox, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand
End If
End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
' Use LongPtr only
Public Sub TimerProcMessageBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
' Closes a dialog box (Shell.Popup or VBA.MsgBox) having a caption stored in MessageBox_Caption
' This TimerProc sends *any* message that can close the dialog: the objective is solely to close
' the dialog and resume the VBA thread. Your caller must detect the expired TimerProc interval
' and insert a custom return value (or default) that signals the 'Timeout' for responses.
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As LongPtr ' Handle to VBA MsgBox
Dim iDlgCommand As VbMsgBoxResult ' Dialog command values: OK, CANCEL, YES, NO, etc
KillTimer hwnd, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand
End If
End Sub
#Else ' 32 bit Excel
Public Sub TimerProcMessageBox(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function msgPopup
' The MsgPopup implementation in this project returns -1 for this 'Timeout'
Dim hWndMsgBox As Long ' Handle to VBA MsgBox
KillTimer hwnd, idEvent
hWndMsgBox = 0
hWndMsgBox = FindWindow("#32770", MessageBox_Caption)
If hWndMsgBox < > 0 Then
' Enumerate WM_COMMAND values
For iDlgCommand = vbOK To vbNo
If GetDlgItem(hWndMsgBox, iDlgCommand) <> 0 Then
SendMessage hWndMsgBox, WM_COMMAND, iDlgCommand, 0&
Exit For
End If
Next iDlgCommand
End If
End Sub
#End If
And here are the API declarations - note the conditional declarations for VBA7, 64-Bit Windows, and plain-vanilla 32-bit:
' Explanation of compiler constants for 64-Bit VBA and API declarations :
' https://msdn.microsoft.com/en-us/library/office/ee691831(v=office.14).aspx
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows ' Use LongLong and LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr _
) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr _
) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" _
(ByVal hWndDlg As LongPtr, _
ByVal nIDDlgItem As Long _
) As LongPtr
#ElseIf VBA7 Then ' VBA7 in all environments, including 32-Bit Office ' Use LongPtr for ptrSafe declarations, LongLong is not available
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" _
(ByVal hWndDlg As LongPtr, _
ByVal nIDDlgItem As Long _
) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As Long
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function GetDlgItem Lib "user32" _
(ByVal hWndDlg, ByVal nIDDlgItem As Long) As Long
#End If
Private Enum WINDOW_MESSAGE
WM_ACTIVATE = 6
WM_SETFOCUS = 7
WM_KILLFOCUS = 8
WM_PAINT = &HF
WM_CLOSE = &H10
WM_QUIT = &H12
WM_COMMAND = &H111
WM_SYSCOMMAND = &H112
End Enum
' Dialog Box Command IDs - replicates vbMsgBoxResult, with the addition of 'dlgTIMEOUT'
Public Enum DIALOGBOX_COMMAND
dlgTIMEOUT = -1
dlgOK = 1
dlgCANCEL = 2
dlgABORT = 3
dlgRETRY = 4
dlgIGNORE = 5
dlgYES = 6
dlgNO = 7
End Enum
A final note: I would welcome suggestions for improvement from experienced MFC C++ developers, as you are going to have a much better grasp of the basic Windows message-passing concepts underlying a 'Dialog' window - I work in an oversimplified language and it is likely that the oversimplifications in my understanding have crossed the line into outright errors in my explanation.
Going with Answer A. the Win32 solution. This meets the requirements, and is robust from testing so far.
Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Sub MsgBoxDelay()
Const cmsg As String = "Yes or No? leaving this window for 1 min is the same as clicking Yes."
Const cTitle As String = "popup window"
Dim retval As Long
retval = MessageBoxTimeout(FindWindow(vbNullString, Title), cmsg, cTitle, 4, 0, 60000)
If retval <> 7 Then
Call MethodFoo
End If
End Sub
Easy
Call CreateObject("WScript.Shell").Popup("Timed message box", 1, "Title", vbOKOnly)
Starting with the samples in this post my final code is as follows:
' Coded by Clint Smith
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' tMsgBox Function (Timered Message Box)
' By Clint Smith, clintasm#gmail.com
' Created 04-Sep-2014
' Updated for 64-bit 03-Mar-2020
' This provides an publicly accessible procedure named
' tMsgBox that when invoked instantiates a timered
' message box. Many constants predefined for easy use.
' There is also a global result variable tMsgBoxResult.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Const mbBTN_Ok = vbOKOnly 'Default
Public Const mbBTN_OkCancel = vbOKCancel
Public Const mbBTN_AbortRetryIgnore = vbAbortRetryIgnore
Public Const mbBTN_YesNoCancel = vbYesNoCancel
Public Const mbBTN_YesNo = vbYesNo
Public Const mbBTN_RetryCancel = vbRetryCancel
Public Const mbBTN_CanceTryagainContinue = &H6
Public Const mbICON_Stop = vbCritical
Public Const mbICON_Question = vbQuestion
Public Const mbICON_Exclaim = vbExclamation
Public Const mbICON_Info = vbInformation
Public Const mbBTN_2ndDefault = vbDefaultButton2
Public Const mbBTN_3rdDefault = vbDefaultButton3
Public Const mbBTN_4rdDefault = vbDefaultButton4
Public Const mbBOX_Modal = vbSystemModal
Public Const mbBTN_AddHelp = vbMsgBoxHelpButton
Public Const mbTXT_RightJustified = vbMsgBoxRight
Public Const mbWIN_Top = &H40000 'Default
Public Const mbcTimeOut = 32000
Public Const mbcOk = vbOK
Public Const mbcCancel = vbCancel
Public Const mbcAbort = vbAbort
Public Const mbcRetry = vbRetry
Public Const mbcIgnore = vbIgnore
Public Const mbcYes = vbYes
Public Const mbcNo = vbNo
Public Const mbcTryagain = 10
Public Const mbcContinue = 11
Public Const wAccessWin = "OMain"
Public Const wExcelWin = "XLMAIN"
Public Const wWordWin = "OpusApp"
Public tMsgBoxResult As Long
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function tMsgBoxA Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare Function tMsgBoxA Lib "user32.dll" Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As Long, _
ByVal wLanguageID As Long, _
ByVal lngMilliseconds As Long) As Long
#End If
Public Sub tMsgBox( _
Optional sMessage As String = "Default: (10 sec timeout)" & vbLf & "Coded by Clint Smith", _
Optional sTitle As String = "Message Box with Timer", _
Optional iTimer As Integer = 10, _
Optional hNtype As Long = mbBTN_Ok + mbWIN_Top, _
Optional hLangID As Long = &H0, _
Optional wParentType As String = vbNullString, _
Optional wParentName As String = vbNullString)
tMsgBoxResult = tMsgBoxA(FindWindow(wParentType, wParentName), sMessage, sTitle, hNtype, hLangID, 1000 * iTimer)
End Sub
Private Declare Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal MsgText As String, _
ByVal Title As String, _
ByVal MsgBoxType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal Timeout As Long) _
As Long
Dim btnOK As Boolean
Dim btnCancel As Boolean
Dim MsgTimeOut As Boolean
Option Explicit
Sub Main
AutoMsgbox("Message Text", "Title", vbOkCancel , 5) '5 sec TimeOut
MsgBox("Pressed OK: " & btnOK & vbNewLine & "Pressed Cancel: " & btnCancel & vbNewLine &"MsgBox Timeout: " & MsgTimeOut)
End Sub
Function AutoMsgbox(MsgText , Title , MsgBoxType , Timeout)
Dim ReturnValue
Dim TimeStamp As Date
TimeStamp = DateAdd("s",Timeout,Now)
Dim MsgText1 As String
Dim TimeOutCounter As Integer
For TimeOutCounter = 0 To Timeout
MsgText1 = MsgText & vbNewLine & vbNewLine & " Auto Selction in " & Timeout - TimeOutCounter & " [s]"
ReturnValue = MsgBoxTimeout(0 , MsgText1 , Title, MsgBoxType, 0 ,1000)
Select Case ReturnValue
Case 1
btnOK = True
btnCancel = False
btnAbort = False
btnRetry = False
btnIgnore = False
btnYes = False
btnNo = False
MsgTimeOut = False
Exit Function
Case 2
btnOK = False
btnCancel = True
btnAbort = False
btnRetry = False
btnIgnore = False
btnYes = False
btnNo = False
MsgTimeOut = False
Exit Function
Case 3
btnOK = False
btnCancel = False
btnAbort = True
btnRetry = False
btnIgnore = False
btnYes = False
btnNo = False
MsgTimeOut = False
Exit Function
Case 4
btnOK = False
btnCancel = False
btnAbort = False
btnRetry = True
btnIgnore = False
btnYes = False
btnNo = False
MsgTimeOut = False
Exit Function
Case 5
btnOK = False
btnCancel = False
btnAbort = False
btnRetry = False
btnIgnore = True
btnYes = False
btnNo = False
MsgTimeOut = False
Exit Function
Case 6
btnOK = False
btnCancel = False
btnAbort = False
btnRetry = False
btnIgnore = False
btnYes = True
btnNo = False
MsgTimeOut = False
Exit Function
Case 7
btnOK = False
btnCancel = False
btnAbort = False
btnRetry = False
btnIgnore = False
btnYes = False
btnNo = True
MsgTimeOut = False
Exit Function
Case 32000
btnOK = False
btnCancel = False
btnAbort = False
btnRetry = False
btnIgnore = False
btnYes = False
btnNo = False
MsgTimeOut = True
Next TimeOutCounter
End Function