Position of a MsgBox
Alan Linton
I am using Excel 97 and Windows 95.
--
Alan Linton
Robert Rosenberg
InputBoxes can.
_______________
Robert Rosenberg
RCOR Consulting
Microsoft MVP - Excel
"Alan Linton" <al...@cranley.demon.co.uk> wrote in message
news:iYA+tFAb...@cranley.demon.co.uk...
Stratos Malasiotis
My answer to your question would be that it is NOT (practically)
possible to position it.
A message box is a Windows-level feature, not Excel-only, and even
you 'hardcore'-produce a messagebox using the respective dll functions,
you are not provided with an interface to position it.
A message box is, however, still a window object and therefore it can
be located and positioned after creating it. You could therefore use a
Windows Callback function to do that positioning action as Jim Rech
demostrated a couple of days ago. Something like that would require an
AddressOf keyword that exists only in Excel2000. You could use K.Getz's
AdrOf function as a workaround for Excel 97. I could also show you a
couple more ways to do it without using Windows callbacks.
In all cases though you'll have to write *many* lines of advanced
code just to produce a MsgBox. Therefore my suggestion would be if you
really need to position a message box use a userform or a baloon
instead.
HTH
Stratos
Stratos Malasiotis
Not much movement in the newsgroup today :-)
I have re-writen Jim Rech's procedure in combination with K.Getz's
AddrOf for positioning a message box in Excel 97.
I still believe that it is a bad idea, but I though that it is good to
show hooking and sub-classing examples and is also the AddrOf function
once so often.
Just to emphasise once again that all the intelligent part in this code
listing have **NOT** been done by me.
In a standard module add:
----------------------------------------------------------------------
Sub test1_fncMsgBox_Pos97()
Dim aResult As Long
aResult = fncMsgBox_Pos97(MsgBox_Prompt:="This a message generated
based on techniques designed by Jim Rech and Ken Getz", _
MsgBox_Buttons:=vbOKCancel + vbExclamation, _
MsgBox_Title:="Magic MsgBox", _
MsgBox_Top:=50, _
MsgBox_Left:=50)
If aResult = vbOK Then
fncMsgBox_Pos97 MsgBox_Prompt:="You hit the OK button"
Else
fncMsgBox_Pos97 MsgBox_Prompt:="You hit the Cancel button"
End If
End Sub
---------------------------------------------------------------------
in another standard module add (exactly as it is and ensuring that no
line breaks have been inserted by the email):
-----------------------------------------------------------------------
Option Explicit
Declare Function GetCurrentThreadId _
Lib "kernel32" () _
As Long
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
Declare Function UnhookWindowsHookEx _
Lib "user32" _
( _
ByVal hHook As Long _
) _
As Long
Declare Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongA" _
( _
ByVal hWnd As Long, _
ByVal nIndex As Long _
) _
As Long
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
Declare Function GetCurrentVbaProject _
Lib "vba332.dll" _
Alias "EbGetExecutingProj" _
( _
hProject As Long _
) _
As Long
Declare Function GetFuncID _
Lib "vba332.dll" _
Alias "TipGetFunctionId" _
( _
ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionID As String _
) _
As Long
Declare Function GetAddr _
Lib "vba332.dll" _
Alias "TipGetLpfnOfFunctionId" _
( _
ByVal hProject As Long, _
ByVal strFunctionID As String, _
ByRef lpfn As Long _
) _
As Long
Dim TempHook As Long, _
Callback_MsgBox_Top As Long, _
Callback_MsgBox_Left As Long
Public Function fncMsgBox_Pos97 _
( _
MsgBox_Prompt As String, _
Optional MsgBox_Buttons As Long, _
Optional MsgBox_Title As String = "Microsoft Excel", _
Optional MsgBox_HelpFile As String, _
Optional MsgBox_Context As Long, _
Optional MsgBox_Top As Integer, _
Optional MsgBox_Left As Integer _
) _
As Variant
'
'declarations of Win32 API constants
Const WH_CBT = 5, GWL_HINSTANCE = (-6)
'
'give the msgbox positioning dimensions a module-level scope _
so that the callback function can use them
Callback_MsgBox_Top = MsgBox_Top
Callback_MsgBox_Left = MsgBox_Left
'
'set a Windows hook on the Excel's thread of current instance
TempHook = SetWindowsHookEx _
( _
idHook:=WH_CBT, _
lpfn:=AddrOf("cbkPositionMsgBox"), _
hmod:=GetWindowLong(0, GWL_HINSTANCE), _
dwThreadId:=GetCurrentThreadId() _
)
'
'compose and execute an Excel's message
On Error Resume Next
fncMsgBox_Pos97 = MsgBox(MsgBox_Prompt, _
MsgBox_Buttons, _
MsgBox_Title, _
MsgBox_HelpFile, _
MsgBox_Context _
)
'
'pass the result of the function to the calling procedure
'
End Function
Function cbkPositionMsgBox _
( _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) _
As Long
'Windows callback procedure for positioning the first new active window
'
'declarations of Win32 API constants
Const HCBT_ACTIVATE = 5, _
SWP_NOSIZE = &H1, SWP_NOZORDER = &H4, SWP_NOACTIVATE = &H10
'
'set an error handler so that no error can pass back to Excel
On Error GoTo ExitCallback
'
'action only if Windows sends an HCBT_ACTIVATE message through _
Excel's thread
If lMsg = HCBT_ACTIVATE And _
wParam <> FindWindow("XLMAIN", Application.Caption) Then
'position the window specified by wParam; _
don't affect any other of common MsgBox
SetWindowPos _
hWnd:=wParam, _
hWndInsertAfter:=0, _
x:=Callback_MsgBox_Left, _
y:=Callback_MsgBox_Top, _
cx:=0, _
cy:=0, _
wFlags:=SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
'
'unhook the callback from Excel's thread so that it doesn't apply
to _
subsequesnt actions and Excel can close normally
UnhookWindowsHookEx TempHook
End If
ExitCallback:
cbkPositionMsgBox = 0
End Function
Function AddrOf _
( _
CallbackFunctionName As String _
) _
As Long
'
Dim aResult As Long
Dim CurrentVBProject As Long
Dim strFunctionID As String
Dim AddressofFunction As Long
Dim UniCbkFunctionName As String
'
'convert the name of the function to Unicode system
UniCbkFunctionName = StrConv(CallbackFunctionName, vbUnicode)
'
'if the current VBProjects exists ...
If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then
'... get the function ID of the callback function based on its
name, _
in order to ensure that the function exists
aResult = GetFuncID _
( _
hProject:=CurrentVBProject, _
strFunctionName:=UniCbkFunctionName, _
strFunctionID:=strFunctionID _
)
'if the function exists ...
If aResult = 0 Then
'...get a pointer to the callback function based on
strFunctionID
aResult = GetAddr _
( _
CurrentVBProject, _
strFunctionID, _
lpfn:=AddressofFunction _
)
'if we have got the pointer pass it to the result of the
function
If aResult = 0 Then
AddrOf = AddressofFunction
End If
End If
End If
End Function
------------------------------------------------------------------------------
Swich to Excel and run test1_fncMsgBox_Pos97() from the Macros Dialog or
assign a macro to shape. This should work directly although I can't be
sure of how AddrOf will bahave (it usually works with me).
I haeve made a small modification that allows Jim's callback to work
from the VBE as well (it positions Excel before since that was the first
activated window) but it not the proper way in my opinion.
I haven't checked the function using Help files but I guess there should
not be a problem there.
Stratos Malasiotis
Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" _
( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) _
As Long
in the Api function declarations because i forgot it
sorry :-))
Alan Linton
<ie...@csv.warwick.ac.uk> writes
>..and also add:
[snip]
>> I have re-writen Jim Rech's procedure in combination with K.Getz's
>> AddrOf for positioning a message box in Excel 97.
Amazing! Thanks.
Yet again I am appalled by how little I know compared with the real
experts.
--
Alan Linton