minimaster said:
of course: - very helpful - sory for my german understatement
tendency.
No need to apologise said:
I agree the CBT method is very stable in combination with a runing
VBE.
It's much more stable and less resource intensive that subclassing windows
events, however absolutely must not do anything that would cause the code to
recompile, otherwise Excel will crash! So don't edit the project while the
hook is running.
One small thing, all the dropdown palette icons seem to flicker a bit in
2003-
Yes, I was referring to your comment #2 on Jan.13th. I started a new
workbook from scratch with your posting/code on Jan.14th but
immediatly had the resize problem. Annoying. Maybe I'll leave this
little problem alone for a while before I start to analyze the CBT
messages to see how I can implement there a way to ensure the I see
the UF after the resize.
Lot's of potential there
I agree with your comment about the positioning of the UF. It behaves
a bit strange. For the initial position it is -Application.left * 2 +
the offset to to the right. Afterwards when you switch the parent with
your code the factor must be *1 and not *2. Maybe setwindowsPos is
easier and better to predict. I didn't dig into that one yet.
Better to use GetWindowRect, ie the new container for the form (see demo
below)
Overall I'm happy to see that it is possible with this special UF
setup to simulate a commandbar at the bottom of the main Excel 2007
window, despite MS efforts to make us all use the ribbon interface
instead of the commandbars.
The next challenge I'm interested in is to
"dock" such a userform on the left or the right side of the main Excel
window.
Interesting idea (difficult in Excel 2007 though), see below
Following is a demo to show the form in the Satusbar (all versions) OR in a
dummy commandbar docked to left/right or bottom (xl2000-3 only).
Start a new project a normal module and a userform (note the wb close event
in the ThisWorkbook module).
In the form add three small buttons, sized as suggested in the comments,
*after* adding the buttons add a Label
Add two Forms buttons to a sheet, assigned to macros as detailed in the
comments
In cell D11, enter SB, L, R or B (see GetFormSettings).
Run from the ShowForm button
do *not* edit code while the form and hook is running
Have fun !
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Userform1
' put 3 fairly small buttons on the form, say wd/ht 30x18
' then a label, say wd/ht 18x18 with no caption
' StartUpPosition: 0 Manual
'
Option Explicit
Private Declare Function SetParent Lib "user32" ( _
ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
Private Declare Function GetParent Lib "user32.dll" ( _
ByVal hwnd As Long) As Long
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 SetWindowLong Lib "user32" Alias _
"SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As
Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
Private mRctXL2 As RECT
Private mhWndForm As Long
Private mhWndBar As Long
Private mhWndEXCEL2 As Long
Dim mbOnBar As Boolean
Private Const GWL_HWNDPARENT As Long = -8
Private Const GWL_STYLE As Long = -16
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_EX_WINDOWEDGE As Long = &H100
Private Sub RemoveTitleBar()
Dim lStyle As Long
' remove title
lStyle = GetWindowLong(ghWndForm, GWL_STYLE)
lStyle = lStyle And Not WS_CAPTION
SetWindowLong ghWndForm, GWL_STYLE, lStyle
' remove frame
lStyle = GetWindowLong(ghWndForm, GWL_EXSTYLE)
lStyle = lStyle And WS_EX_WINDOWEDGE
SetWindowLong ghWndForm, GWL_EXSTYLE, lStyle
DrawMenuBar ghWndForm
End Sub
Public Sub AttachToBar(bToBar As Boolean)
Dim hWndP As Long, res As Long
If bToBar Then
If gbUseEXCEL2 Then
hWndP = mhWndEXCEL2
Else
hWndP = mhWndBar
End If
Else
hWndP = Application.hwnd
End If
res = SetParent(ghWndForm, hWndP)
res = SetWindowLong(ghWndForm, GWL_HWNDPARENT, hWndP)
End Sub
Public Sub PosForm()
Dim d As Double
Dim rctBar As RECT
Dim Points2Pixels As Double
' If gbStatusBar Then
' d = -Application.Left + 60
' Else
' If gBarPos = msoBarRight Then
' d = -Application.Left - Application.Width + 21
' Else
' d = -Application.Left
' End If
' End If
Points2Pixels = 0.75 ' << normally should get this with APIs >>
Call GetWindowRect(mhWndBar, rctBar)
d = -rctBar.Left * Points2Pixels
If gbStatusBar Then
d = d + 60
End If
Me.Left = d
Me.Top = 0
End Sub
Private Sub CommandButton1_Click()
MsgBox CommandButton1.Caption
' Unload Me
End Sub
Private Sub CommandButton2_Click()
MsgBox CommandButton2.Caption
End Sub
Private Sub CommandButton3_Click()
MsgBox CommandButton3.Caption
End Sub
Public Sub UserForm_Activate()
PosForm
End Sub
Private Sub UserForm_Initialize()
Dim bFlag As Boolean
Dim bStatusBar As Boolean
Dim hWndEXCEL2 As Long
Dim sBarClass As String
If Val(Application.Version) >= 10 Then
gHwndApp = Application.hwnd
Else
gHwndApp = FindWindow("XLMAIN", Application.Caption)
End If
Me.Caption = Now
ghWndForm = FindWindow("ThunderDFrame", Me.Caption)
Me.Caption = ghWndForm
If gbStatusBar Then
If Val(Application.Version) >= 12 Then
sBarClass = "EXCEL2"
Else
sBarClass = "EXCEL4"
End If
mhWndBar = FindWindowEx(gHwndApp, 0&, sBarClass, vbNullString)
Else
' our dummy bar is contained in one of the EXCEL2 windows
mhWndEXCEL2 = FindWindowEx(gHwndApp, 0&, "EXCEL2", vbNullString)
Do
mhWndBar = FindWindowEx(mhWndEXCEL2, 0&, "MsoCommandBar", _
"DummyBar1")
If mhWndBar Then
Exit Do
Else
mhWndEXCEL2 = FindWindowEx(gHwndApp, mhWndEXCEL2, _
"EXCEL2", vbNullString)
End If
Loop Until mhWndEXCEL2 = 0
End If
If mhWndBar Then
RemoveTitleBar
AttachToBar True
Else
MsgBox "failed to find the bar window"
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookCBT
dummyBar False
End Sub
''' end Userform
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Normal module
' Put two Forms buttons on a sheet
' assign macros to ShowForm & CloseForm respectively
' Run from the ShowForm button
Option Explicit
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 CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, ByVal nCode As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_CBT = 5
' CBT Hook Codes
Private Const HCBT_MOVESIZE = 0
Private Const HCBT_MINMAX = 1
'Private Const HCBT_QS = 2
'Private Const HCBT_CREATEWND = 3
'Private Const HCBT_DESTROYWND = 4
'Private Const HCBT_ACTIVATE = 5
'Private Const HCBT_CLICKSKIPPED = 6
'Private Const HCBT_KEYSKIPPED = 7
'Private Const HCBT_SYSCOMMAND = 8
'Private Const HCBT_SETFOCUS = 9
' Window State Values
Private Const SW_MAXIMIZE = 3
Private Const SW_MINIMIZE = 6
Private Const SW_RESTORE = 9
Public ghWndForm As Long ' Userform window
Public ghWndBar As Long ' Statusbar or commandbar window
Public gHwndApp As Long ' App window
Public gBarPos As MsoBarPosition ' location for docking
Public gbStatusBar As Boolean ' put form on statusbar or a docked
commandbar
Public gbUseEXCEL2 As Boolean ' experiment form on commandbar container
window
Private m_hHook As Long
Private mbIsMinimized As Boolean
Private mFrm As UserForm1
Sub CloseFrm()
UnhookCBT
If Not mFrm Is Nothing Then
On Error Resume Next
Unload mFrm
End If
dummyBar False
Set mFrm = Nothing
End Sub
Sub ShowForm()
Dim frmPos As Long, dPos As Double
Dim ctl As MSForms.Control
GetFormSettings
Application.DisplayStatusBar = True
gHwndApp = Application.hwnd ' need a different way in Excel 2000
If gbStatusBar = False Then
If Val(Application.Version) >= 12 Then
MsgBox "Can't use Commandbars in Excel7+ !!"
Exit Sub
End If
dummyBar True
End If
Set mFrm = New UserForm1
' align controls horizontally or verticaly
For Each ctl In mFrm.Controls
If gBarPos = msoBarBottom Or gbStatusBar Then
ctl.Top = 0
ctl.Left = dPos
dPos = dPos + ctl.Width
Else
ctl.Left = 0
ctl.Top = dPos
dPos = dPos + ctl.Height
End If
Next
' ensure form is wide or tall enough
If gBarPos = msoBarBottom Or gbStatusBar Then
mFrm.Width = dPos
Else
mFrm.Height = dPos
End If
mFrm.Show vbModeless
HookCBT
End Sub
Private Function GetFormSettings() As Boolean
Dim s As String
' pick up settings from the sheet
' in D11 enter SB statusbar, or L R B docking
Range("C11") = "SB,L,R,B"
s = UCase(Range("D11"))
gbStatusBar = False
Select Case s
Case "SB": gbStatusBar = True
Case "L": gBarPos = msoBarLeft
Case "R": gBarPos = msoBarRight
Case "B": gBarPos = msoBarBottom
Case Else:
Range("D11") = "SB"
gbStatusBar = True
End Select
' ignore this, more work to do with form in the EXCEL2 window
Range("C12") = "use EXCEL2"
gbUseEXCEL2 = CBool(Val(Range("D12"))) ' enter 0 or 1 in D12
End Function
Public Sub dummyBar(bCreate As Boolean)
Dim i As Long, j As Long, cnt As Long
Dim cbr As CommandBar
' delete any old bars
On Error Resume Next
For i = 1 To 2
CommandBars("DummyBar" & i).Delete
Next
On Error GoTo 0
' adjust cnt to add enough buttons for a tad less
' than width or height of the form
If gBarPos = msoBarBottom Then
cnt = 5 ' << adjust
Else
cnt = 3 ' << adjust
End If
' create one or more dummy bars for the form
If bCreate Then
For i = 1 To 1 ' << adjust only if gbUseEXCEL2
Set cbr = CommandBars.Add("DummyBar" & i, gBarPos, , True)
cbr.Visible = True
For j = 1 To cnt
With cbr.Controls.Add
.Style = msoButtonIcon
End With
Next
Next
End If
End Sub
Public Sub HookCBT()
Call UnhookCBT
m_hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, 0&,
GetCurrentThreadId())
End Sub
Public Sub UnhookCBT()
If m_hHook Then
Call UnhookWindowsHookEx(m_hHook)
m_hHook = 0
End If
End Sub
Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal
lParam As Long) As Long
Dim bIsMin As Boolean, b As Boolean
Dim nRet As Long
On Error Resume Next
b = Len(mFrm.Caption)
On Error GoTo 0
If b And (wParam = gHwndApp) Then ' some chagne to xlApp main window
If nCode = HCBT_MINMAX Then
' it's a min/max event
If WordLo(lParam) = SW_MINIMIZE Then
bIsMin = True
Else
' maybe max or normal
bIsMin = False
End If
If bIsMin <> mbIsMinimized Then ' minimize status is changing
mbIsMinimized = bIsMin
mFrm.AttachToBar (Not mbIsMinimized)
If bIsMin Then
mFrm.Hide
Else
mFrm.Show vbModeless
End If
End If
ElseIf nCode = HCBT_MOVESIZE Then
'' it's a resize event
' mFrm.PosForm
End If
End If
CBTProc = CallNextHookEx(m_hHook, nCode, wParam, lParam)
End Function
Private Function WordLo(ByVal LongIn As Long) As Integer
' Low word retrieved by masking off high word.
' If low word is too large, twiddle sign bit.
If (LongIn And &HFFFF&) > &H7FFF Then
WordLo = (LongIn And &HFFFF&) - &H10000
Else
WordLo = LongIn And &HFFFF&
End If
End Function
'' end normal module
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''
'' ThisWorkbook module
Private Sub Workbook_BeforeClose(Cancel As Boolean)
CloseFrm
End Sub
Regards,
Peter T
