xl97 doesn't support "AddressOf"
Here is a past posting that should work in xl97:
http://groups.google.com/[email protected]&output=gplain
Position a Message box by Stratos:
From: Stratos Malasiotis <
[email protected]>
Subject: Re: Msg Box
Date: 2000/08/12
Message-ID: <
[email protected]>
Content-Transfer-Encoding: 7bit
References: <
[email protected]>
To: Morris Gray <
[email protected]>
X-Accept-Language: en
Content-Type: text/plain; charset=us-ascii
X-Complaints-To: (e-mail address removed)
X-Trace: wisteria.csv.warwick.ac.uk 966091252 9682 137.205.42.204 (12 Aug
2000 14:40:52 GMT)
Organization: University of Warwick, UK
Mime-Version: 1.0
NNTP-Posting-Date: 12 Aug 2000 14:40:52 GMT
Newsgroups: microsoft.public.excel.programming
Hi Morris,
Last week someone asked the same question to whome I replied with the
following function.
It was originally designed by Jim Rech; I just convert his technique to a
function , nothing more.
It is designed for XL97 ; if it doesn't work in 2000 (it should) you'll have
to replace K.Getz's AddrOf function with the build in AddessOf
function.
In a standard module add:
-------------------------------------------------------
Sub test1_fncMsgBox_Pos97()
Dim aResult As Long
aResult = fncMsgBox_Pos97(MsgBox_Prompt:="This a message box with a touch of
magic", _
MsgBox_Buttons:=vbOKCancel + vbExclamation, _
MsgBox_Title:="Magic MsgBox", _
MsgBox_Top:=50, _
MsgBox_Left:=500)
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
--------------------------------------------------
and in another:
----------------------------------------------------
Option Explicit
Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" _
( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) _
As Long
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
'wraps the common Excel's MsgBox function with a callback function that
'positions the msgbox window after it is created
'
'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 activated 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 and the activated window is not Excel itself
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 attributes
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, CurrentVBProject As Long, strFunctionID As String,
_
AddressofFunction As Long, 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
----------------------------------------------------------------------------
------------
HTH
Stratos
========================================
