Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Anything wrong with Messagebox API?
As I wanted to alter the captions of the standard Msgbox I had a look at the
Messagebox API and after altering some code I found it seems this is working nicely. I know I could use a Userform for this, but I want to keep resources down and wasn't keen to add yet another Userform to the project. The only thing that is a slight problem is that the buttons don't resize with the caption, but I can keep the caption lenghth down. The other thing is that this msgbox is modeless and that would seem a good thing, but I am just wondering if anybody is aware of any problems that could arise from this code: Option Explicit Private Const MB_YESNOCANCEL = &H3& Private Const MB_YESNO = &H4& Private Const MB_RETRYCANCEL = &H5& Private Const MB_OKCANCEL = &H1& Private Const MB_OK = &H0& Private Const MB_ABORTRETRYIGNORE = &H2& Private Const MB_ICONEXCLAMATION = &H30& Private Const MB_ICONQUESTION = &H20& Private Const MB_ICONASTERISK = &H40& Private Const MB_ICONINFORMATION = MB_ICONASTERISK Private Const IDOK = 1 Private Const IDCANCEL = 2 Private Const IDABORT = 3 Private Const IDRETRY = 4 Private Const IDIGNORE = 5 Private Const IDYES = 6 Private Const IDNO = 7 Private Const IDPROMPT = &HFFFF& Private Const WH_CBT = 5 Private Const GWL_HINSTANCE = (-6) Private Const HCBT_ACTIVATE = 5 Private Type MSGBOX_HOOK_PARAMS hwndOwner As Long hHook As Long End Type Private MSGHOOK As MSGBOX_HOOK_PARAMS Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long Public Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowLong Lib "user32" Alias _ "GetWindowLongA" (ByVal hwnd As Long, _ ByVal nIndex As Long) As Long Private Declare Function MessageBox Lib "user32" _ Alias "MessageBoxA" (ByVal hwnd As Long, _ ByVal lpText As String, _ ByVal lpCaption As String, _ ByVal wType As Long) As Long Private Declare Function SetDlgItemText _ Lib "user32" _ Alias "SetDlgItemTextA" (ByVal hDlg As Long, _ ByVal nIDDlgItem As Long, _ ByVal lpString As String) As Long Private Declare Function SetWindowsHookEx _ Lib "user32" _ Alias "SetWindowsHookExA" (ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function SetWindowText _ Lib "user32" _ Alias "SetWindowTextA" (ByVal hwnd As Long, _ ByVal lpString As String) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private mbFlags As VbMsgBoxStyle Private mbFlags2 As VbMsgBoxStyle Private mTitle As String Private mPrompt As String Private But1 As String Private But2 As String Private But3 As String Function FARPROC(ByVal pfn As Long) As Long 'Procedure that receives and returns 'the passed value of the AddressOf operator. 'This workaround is needed as you can't assign 'AddressOf directly to a member of a user- 'defined type, but you can assign it to another 'long and use that (as returned here) FARPROC = pfn End Function Function MessageBoxH(hwndThreadOwner As Long, _ hwndOwner As Long, _ mbFlags As VbMsgBoxStyle, _ strTitle As String, _ strPrompt As String) As Long 'This function calls the hook Dim hInstance As Long Dim hThreadId As Long hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE) hThreadId = GetCurrentThreadId() With MSGHOOK .hwndOwner = hwndOwner .hHook = SetWindowsHookEx(WH_CBT, _ FARPROC(AddressOf MsgBoxHookProc), _ hInstance, _ hThreadId) End With MessageBoxH = MessageBox(hwndOwner, _ strPrompt, _ strTitle, _ mbFlags) End Function Function MsgBoxHookProc(ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long 'This function catches the messagebox before it opens 'and changes the text of the buttons - then removes the hook If uMsg = HCBT_ACTIVATE Then SetWindowText wParam, mTitle SetDlgItemText wParam, IDPROMPT, mPrompt Select Case mbFlags Case vbAbortRetryIgnore, _ vbAbortRetryIgnore + vbDefaultButton1, _ vbAbortRetryIgnore + vbDefaultButton2, _ vbAbortRetryIgnore + vbDefaultButton3 SetDlgItemText wParam, IDABORT, But1 SetDlgItemText wParam, IDRETRY, But2 SetDlgItemText wParam, IDIGNORE, But3 Case vbYesNoCancel, _ vbYesNoCancel + vbDefaultButton1, _ vbYesNoCancel + vbDefaultButton2, _ vbYesNoCancel + vbDefaultButton3 SetDlgItemText wParam, IDYES, But1 SetDlgItemText wParam, IDNO, But2 SetDlgItemText wParam, IDCANCEL, But3 Case vbOKOnly SetDlgItemText wParam, IDOK, But1 Case vbRetryCancel, _ vbRetryCancel + vbDefaultButton1, _ vbRetryCancel + vbDefaultButton2 SetDlgItemText wParam, IDRETRY, But1 SetDlgItemText wParam, IDCANCEL, But2 Case vbYesNo, _ vbYesNo + vbDefaultButton1, _ vbYesNo + vbDefaultButton2 SetDlgItemText wParam, IDYES, But1 SetDlgItemText wParam, IDNO, But2 Case vbOKCancel, _ vbOKCancel + vbDefaultButton1, _ vbOKCancel + vbDefaultButton2 SetDlgItemText wParam, IDOK, But1 SetDlgItemText wParam, IDCANCEL, But2 End Select UnhookWindowsHookEx MSGHOOK.hHook End If MsgBoxHookProc = False End Function Function APIMsgBox(lHwnd As Long, _ mMsgbox As VbMsgBoxStyle, _ strTitle As String, _ strPrompt As String, _ Optional mMsgIcon As VbMsgBoxStyle, _ Optional strButA As String, _ Optional strButB As String, _ Optional strButC As String) As String 'This function sets your custom parameters and returns 'which button was pressed as a string Dim mReturn As Long mbFlags = mMsgbox mbFlags2 = mMsgIcon mTitle = strTitle mPrompt = strPrompt But1 = strButA But2 = strButB But3 = strButC mReturn = MessageBoxH(lHwnd, _ GetDesktopWindow(), _ mbFlags Or mbFlags2, _ strTitle, _ strPrompt) Select Case mReturn Case IDABORT APIMsgBox = But1 Case IDRETRY APIMsgBox = But2 Case IDIGNORE APIMsgBox = But3 Case IDYES APIMsgBox = But1 Case IDNO APIMsgBox = But2 Case IDCANCEL APIMsgBox = But3 Case IDOK APIMsgBox = But1 End Select End Function Sub Test() Dim strReturn As String strReturn = APIMsgBox(Application.hwnd, _ vbYesNoCancel + vbDefaultButton2, _ "Messagebox Title", _ "Messagebox Prompt", , _ "Button 1", _ "Button 2", _ "Button 3") MsgBox "You pressed " & strReturn End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Anything wrong with Messagebox API?
Hi Bart,
No idea about "any problems that could arise from this code", except a heads-up as I know you need to cater for xl2000 - which doesn't support "Application.hwnd". Public Declare Function FindWindow32 Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long nHWnd = FindWindow32("XLMAIN", Application.Caption) With this change works fine in my xl2k Regards, Peter T "RB Smissaert" wrote in message ... As I wanted to alter the captions of the standard Msgbox I had a look at the Messagebox API and after altering some code I found it seems this is working nicely. I know I could use a Userform for this, but I want to keep resources down and wasn't keen to add yet another Userform to the project. The only thing that is a slight problem is that the buttons don't resize with the caption, but I can keep the caption lenghth down. The other thing is that this msgbox is modeless and that would seem a good thing, but I am just wondering if anybody is aware of any problems that could arise from this code: Option Explicit Private Const MB_YESNOCANCEL = &H3& Private Const MB_YESNO = &H4& Private Const MB_RETRYCANCEL = &H5& Private Const MB_OKCANCEL = &H1& Private Const MB_OK = &H0& Private Const MB_ABORTRETRYIGNORE = &H2& Private Const MB_ICONEXCLAMATION = &H30& Private Const MB_ICONQUESTION = &H20& Private Const MB_ICONASTERISK = &H40& Private Const MB_ICONINFORMATION = MB_ICONASTERISK Private Const IDOK = 1 Private Const IDCANCEL = 2 Private Const IDABORT = 3 Private Const IDRETRY = 4 Private Const IDIGNORE = 5 Private Const IDYES = 6 Private Const IDNO = 7 Private Const IDPROMPT = &HFFFF& Private Const WH_CBT = 5 Private Const GWL_HINSTANCE = (-6) Private Const HCBT_ACTIVATE = 5 Private Type MSGBOX_HOOK_PARAMS hwndOwner As Long hHook As Long End Type Private MSGHOOK As MSGBOX_HOOK_PARAMS Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long Public Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowLong Lib "user32" Alias _ "GetWindowLongA" (ByVal hwnd As Long, _ ByVal nIndex As Long) As Long Private Declare Function MessageBox Lib "user32" _ Alias "MessageBoxA" (ByVal hwnd As Long, _ ByVal lpText As String, _ ByVal lpCaption As String, _ ByVal wType As Long) As Long Private Declare Function SetDlgItemText _ Lib "user32" _ Alias "SetDlgItemTextA" (ByVal hDlg As Long, _ ByVal nIDDlgItem As Long, _ ByVal lpString As String) As Long Private Declare Function SetWindowsHookEx _ Lib "user32" _ Alias "SetWindowsHookExA" (ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function SetWindowText _ Lib "user32" _ Alias "SetWindowTextA" (ByVal hwnd As Long, _ ByVal lpString As String) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private mbFlags As VbMsgBoxStyle Private mbFlags2 As VbMsgBoxStyle Private mTitle As String Private mPrompt As String Private But1 As String Private But2 As String Private But3 As String Function FARPROC(ByVal pfn As Long) As Long 'Procedure that receives and returns 'the passed value of the AddressOf operator. 'This workaround is needed as you can't assign 'AddressOf directly to a member of a user- 'defined type, but you can assign it to another 'long and use that (as returned here) FARPROC = pfn End Function Function MessageBoxH(hwndThreadOwner As Long, _ hwndOwner As Long, _ mbFlags As VbMsgBoxStyle, _ strTitle As String, _ strPrompt As String) As Long 'This function calls the hook Dim hInstance As Long Dim hThreadId As Long hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE) hThreadId = GetCurrentThreadId() With MSGHOOK .hwndOwner = hwndOwner .hHook = SetWindowsHookEx(WH_CBT, _ FARPROC(AddressOf MsgBoxHookProc), _ hInstance, _ hThreadId) End With MessageBoxH = MessageBox(hwndOwner, _ strPrompt, _ strTitle, _ mbFlags) End Function Function MsgBoxHookProc(ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long 'This function catches the messagebox before it opens 'and changes the text of the buttons - then removes the hook If uMsg = HCBT_ACTIVATE Then SetWindowText wParam, mTitle SetDlgItemText wParam, IDPROMPT, mPrompt Select Case mbFlags Case vbAbortRetryIgnore, _ vbAbortRetryIgnore + vbDefaultButton1, _ vbAbortRetryIgnore + vbDefaultButton2, _ vbAbortRetryIgnore + vbDefaultButton3 SetDlgItemText wParam, IDABORT, But1 SetDlgItemText wParam, IDRETRY, But2 SetDlgItemText wParam, IDIGNORE, But3 Case vbYesNoCancel, _ vbYesNoCancel + vbDefaultButton1, _ vbYesNoCancel + vbDefaultButton2, _ vbYesNoCancel + vbDefaultButton3 SetDlgItemText wParam, IDYES, But1 SetDlgItemText wParam, IDNO, But2 SetDlgItemText wParam, IDCANCEL, But3 Case vbOKOnly SetDlgItemText wParam, IDOK, But1 Case vbRetryCancel, _ vbRetryCancel + vbDefaultButton1, _ vbRetryCancel + vbDefaultButton2 SetDlgItemText wParam, IDRETRY, But1 SetDlgItemText wParam, IDCANCEL, But2 Case vbYesNo, _ vbYesNo + vbDefaultButton1, _ vbYesNo + vbDefaultButton2 SetDlgItemText wParam, IDYES, But1 SetDlgItemText wParam, IDNO, But2 Case vbOKCancel, _ vbOKCancel + vbDefaultButton1, _ vbOKCancel + vbDefaultButton2 SetDlgItemText wParam, IDOK, But1 SetDlgItemText wParam, IDCANCEL, But2 End Select UnhookWindowsHookEx MSGHOOK.hHook End If MsgBoxHookProc = False End Function Function APIMsgBox(lHwnd As Long, _ mMsgbox As VbMsgBoxStyle, _ strTitle As String, _ strPrompt As String, _ Optional mMsgIcon As VbMsgBoxStyle, _ Optional strButA As String, _ Optional strButB As String, _ Optional strButC As String) As String 'This function sets your custom parameters and returns 'which button was pressed as a string Dim mReturn As Long mbFlags = mMsgbox mbFlags2 = mMsgIcon mTitle = strTitle mPrompt = strPrompt But1 = strButA But2 = strButB But3 = strButC mReturn = MessageBoxH(lHwnd, _ GetDesktopWindow(), _ mbFlags Or mbFlags2, _ strTitle, _ strPrompt) Select Case mReturn Case IDABORT APIMsgBox = But1 Case IDRETRY APIMsgBox = But2 Case IDIGNORE APIMsgBox = But3 Case IDYES APIMsgBox = But1 Case IDNO APIMsgBox = But2 Case IDCANCEL APIMsgBox = But3 Case IDOK APIMsgBox = But1 End Select End Function Sub Test() Dim strReturn As String strReturn = APIMsgBox(Application.hwnd, _ vbYesNoCancel + vbDefaultButton2, _ "Messagebox Title", _ "Messagebox Prompt", , _ "Button 1", _ "Button 2", _ "Button 3") MsgBox "You pressed " & strReturn End Sub |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Anything wrong with Messagebox API?
Hi Peter,
Yes, I forgot about that one and will alter the code. Thanks for alerting me. The other thing is that the msgbox can sometimes disappear, needing Alt + Tab, as it is modeless. Otherwise it seems fine and it nice to be able to give the buttons different captions, without having to make another userform. RBS "Peter T" <peter_t@discussions wrote in message ... Hi Bart, No idea about "any problems that could arise from this code", except a heads-up as I know you need to cater for xl2000 - which doesn't support "Application.hwnd". Public Declare Function FindWindow32 Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long nHWnd = FindWindow32("XLMAIN", Application.Caption) With this change works fine in my xl2k Regards, Peter T "RB Smissaert" wrote in message ... As I wanted to alter the captions of the standard Msgbox I had a look at the Messagebox API and after altering some code I found it seems this is working nicely. I know I could use a Userform for this, but I want to keep resources down and wasn't keen to add yet another Userform to the project. The only thing that is a slight problem is that the buttons don't resize with the caption, but I can keep the caption lenghth down. The other thing is that this msgbox is modeless and that would seem a good thing, but I am just wondering if anybody is aware of any problems that could arise from this code: Option Explicit Private Const MB_YESNOCANCEL = &H3& Private Const MB_YESNO = &H4& Private Const MB_RETRYCANCEL = &H5& Private Const MB_OKCANCEL = &H1& Private Const MB_OK = &H0& Private Const MB_ABORTRETRYIGNORE = &H2& Private Const MB_ICONEXCLAMATION = &H30& Private Const MB_ICONQUESTION = &H20& Private Const MB_ICONASTERISK = &H40& Private Const MB_ICONINFORMATION = MB_ICONASTERISK Private Const IDOK = 1 Private Const IDCANCEL = 2 Private Const IDABORT = 3 Private Const IDRETRY = 4 Private Const IDIGNORE = 5 Private Const IDYES = 6 Private Const IDNO = 7 Private Const IDPROMPT = &HFFFF& Private Const WH_CBT = 5 Private Const GWL_HINSTANCE = (-6) Private Const HCBT_ACTIVATE = 5 Private Type MSGBOX_HOOK_PARAMS hwndOwner As Long hHook As Long End Type Private MSGHOOK As MSGBOX_HOOK_PARAMS Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long Public Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowLong Lib "user32" Alias _ "GetWindowLongA" (ByVal hwnd As Long, _ ByVal nIndex As Long) As Long Private Declare Function MessageBox Lib "user32" _ Alias "MessageBoxA" (ByVal hwnd As Long, _ ByVal lpText As String, _ ByVal lpCaption As String, _ ByVal wType As Long) As Long Private Declare Function SetDlgItemText _ Lib "user32" _ Alias "SetDlgItemTextA" (ByVal hDlg As Long, _ ByVal nIDDlgItem As Long, _ ByVal lpString As String) As Long Private Declare Function SetWindowsHookEx _ Lib "user32" _ Alias "SetWindowsHookExA" (ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function SetWindowText _ Lib "user32" _ Alias "SetWindowTextA" (ByVal hwnd As Long, _ ByVal lpString As String) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" _ (ByVal hHook As Long) As Long Private mbFlags As VbMsgBoxStyle Private mbFlags2 As VbMsgBoxStyle Private mTitle As String Private mPrompt As String Private But1 As String Private But2 As String Private But3 As String Function FARPROC(ByVal pfn As Long) As Long 'Procedure that receives and returns 'the passed value of the AddressOf operator. 'This workaround is needed as you can't assign 'AddressOf directly to a member of a user- 'defined type, but you can assign it to another 'long and use that (as returned here) FARPROC = pfn End Function Function MessageBoxH(hwndThreadOwner As Long, _ hwndOwner As Long, _ mbFlags As VbMsgBoxStyle, _ strTitle As String, _ strPrompt As String) As Long 'This function calls the hook Dim hInstance As Long Dim hThreadId As Long hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE) hThreadId = GetCurrentThreadId() With MSGHOOK .hwndOwner = hwndOwner .hHook = SetWindowsHookEx(WH_CBT, _ FARPROC(AddressOf MsgBoxHookProc), _ hInstance, _ hThreadId) End With MessageBoxH = MessageBox(hwndOwner, _ strPrompt, _ strTitle, _ mbFlags) End Function Function MsgBoxHookProc(ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long 'This function catches the messagebox before it opens 'and changes the text of the buttons - then removes the hook If uMsg = HCBT_ACTIVATE Then SetWindowText wParam, mTitle SetDlgItemText wParam, IDPROMPT, mPrompt Select Case mbFlags Case vbAbortRetryIgnore, _ vbAbortRetryIgnore + vbDefaultButton1, _ vbAbortRetryIgnore + vbDefaultButton2, _ vbAbortRetryIgnore + vbDefaultButton3 SetDlgItemText wParam, IDABORT, But1 SetDlgItemText wParam, IDRETRY, But2 SetDlgItemText wParam, IDIGNORE, But3 Case vbYesNoCancel, _ vbYesNoCancel + vbDefaultButton1, _ vbYesNoCancel + vbDefaultButton2, _ vbYesNoCancel + vbDefaultButton3 SetDlgItemText wParam, IDYES, But1 SetDlgItemText wParam, IDNO, But2 SetDlgItemText wParam, IDCANCEL, But3 Case vbOKOnly SetDlgItemText wParam, IDOK, But1 Case vbRetryCancel, _ vbRetryCancel + vbDefaultButton1, _ vbRetryCancel + vbDefaultButton2 SetDlgItemText wParam, IDRETRY, But1 SetDlgItemText wParam, IDCANCEL, But2 Case vbYesNo, _ vbYesNo + vbDefaultButton1, _ vbYesNo + vbDefaultButton2 SetDlgItemText wParam, IDYES, But1 SetDlgItemText wParam, IDNO, But2 Case vbOKCancel, _ vbOKCancel + vbDefaultButton1, _ vbOKCancel + vbDefaultButton2 SetDlgItemText wParam, IDOK, But1 SetDlgItemText wParam, IDCANCEL, But2 End Select UnhookWindowsHookEx MSGHOOK.hHook End If MsgBoxHookProc = False End Function Function APIMsgBox(lHwnd As Long, _ mMsgbox As VbMsgBoxStyle, _ strTitle As String, _ strPrompt As String, _ Optional mMsgIcon As VbMsgBoxStyle, _ Optional strButA As String, _ Optional strButB As String, _ Optional strButC As String) As String 'This function sets your custom parameters and returns 'which button was pressed as a string Dim mReturn As Long mbFlags = mMsgbox mbFlags2 = mMsgIcon mTitle = strTitle mPrompt = strPrompt But1 = strButA But2 = strButB But3 = strButC mReturn = MessageBoxH(lHwnd, _ GetDesktopWindow(), _ mbFlags Or mbFlags2, _ strTitle, _ strPrompt) Select Case mReturn Case IDABORT APIMsgBox = But1 Case IDRETRY APIMsgBox = But2 Case IDIGNORE APIMsgBox = But3 Case IDYES APIMsgBox = But1 Case IDNO APIMsgBox = But2 Case IDCANCEL APIMsgBox = But3 Case IDOK APIMsgBox = But1 End Select End Function Sub Test() Dim strReturn As String strReturn = APIMsgBox(Application.hwnd, _ vbYesNoCancel + vbDefaultButton2, _ "Messagebox Title", _ "Messagebox Prompt", , _ "Button 1", _ "Button 2", _ "Button 3") MsgBox "You pressed " & strReturn End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
To show a messagebox | Excel Discussion (Misc queries) | |||
MessageBox with tick box | Excel Discussion (Misc queries) | |||
Printing messagebox | Excel Discussion (Misc queries) | |||
messagebox problem | Excel Programming | |||
Working around a messagebox | Excel Programming |