vbAccelerator - Contents of code file: cDialogCentre.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cCommonDialogCentre"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Type RECT
Left As Long
Top As Long
right As Long
bottom As Long
End Type
Private Type MONITORINFO
cbSize As Long
rcMonitor As RECT
rcWork As RECT
dwFlags As Long
End Type
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As
Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As
Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal
hwnd As Long, ByVal lpString As String) As Long
Private Const WM_DESTROY = &H2
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA"
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal
wParam As Long, ByVal lParam 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 SetWindowLong Lib "user32" Alias "SetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As
Long, lpdwProcessId As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Const GWL_WNDPROC = (-4)
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal
hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetDlgCtrlID Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x
As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
bRepaint As Long) As Long
Private Declare Function MonitorFromWindow Lib "user32" (ByVal hwnd As Long,
ByVal dwFlags As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef
lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetMonitorInfoA Lib "user32" ( _
ByVal hMonitor As Long, _
lpmi As MONITORINFO _
) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
As RECT) As Long
Private Const MONITOR_DEFAULTTONEAREST = 0
Private Const HCBT_CREATEWND = 3
Private Const HCBT_DESTROYWND = 4
Private Const WM_INITDIALOG = &H110
Private Const SPI_GETWORKAREA = &H30&
Implements IWindowsHook
Implements ISubclass
Private m_bHook As Boolean
Private m_frmCentreTo As Object
Private m_lWidth As Long
Private m_lHeight As Long
Public Sub Start( _
frmCentreTo As Object, _
Optional ByVal lMinWidth As Long = -1, _
Optional ByVal lMinHeight As Long = -1 _
)
Set m_frmCentreTo = frmCentreTo
m_lWidth = lMinWidth
m_lHeight = lMinHeight
m_bHook = True
InstallHook Me, WH_CBT
End Sub
Private Sub Class_Terminate()
If (m_bHook) Then
RemoveHook Me, WH_CBT
End If
m_bHook = False
End Sub
Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer6.EMsgResponse)
'
End Property
Private Property Get ISubclass_MsgResponse() As SSubTimer6.EMsgResponse
ISubclass_MsgResponse = emrPreprocess
End Property
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim rectCentreTo As RECT
Dim rectDialog As RECT
Dim rectWork As RECT
Dim rectCentred As RECT
Dim hMon As Long
Dim lOffset As Long
GetWindowRect hwnd, rectDialog
If (rectDialog.right - rectDialog.Left) < m_lWidth Then
rectDialog.right = rectDialog.Left + m_lWidth
End If
If (rectDialog.bottom - rectDialog.Top) < m_lHeight Then
rectDialog.bottom = rectDialog.Top + m_lHeight
End If
GetWindowRect m_frmCentreTo.hwnd, rectCentreTo
On Error Resume Next
hMon = MonitorFromWindow(m_frmCentreTo.hwnd, MONITOR_DEFAULTTONEAREST)
On Error GoTo 0
If (hMon = 0) Then
SystemParametersInfo SPI_GETWORKAREA, 0, rectWork, 0
Else
Dim tMI As MONITORINFO
tMI.cbSize = Len(tMI)
GetMonitorInfoA hMon, tMI
LSet rectWork = tMI.rcWork
End If
' Centre:
rectCentred.Left = rectCentreTo.Left + ((rectCentreTo.right -
rectCentreTo.Left) - (rectDialog.right - rectDialog.Left)) \ 2
rectCentred.Top = rectCentreTo.Top + ((rectCentreTo.bottom -
rectCentreTo.Top) - (rectDialog.bottom - rectDialog.Top)) \ 2
rectCentred.right = rectCentred.Left + (rectDialog.right - rectDialog.Left)
rectCentred.bottom = rectCentred.Top + (rectDialog.bottom - rectDialog.Top)
If (rectCentred.Left < rectWork.Left) Then
lOffset = (rectWork.Left - rectCentred.Left)
rectCentred.Left = rectCentred.Left + lOffset
rectCentred.right = rectCentred.right + lOffset
End If
If (rectCentred.right > rectWork.right) Then
lOffset = (rectCentred.right - rectWork.right)
rectCentred.Left = rectCentred.Left - lOffset
rectCentred.right = rectCentred.right - lOffset
End If
If (rectCentred.Top < rectWork.Top) Then
lOffset = (rectWork.Top - rectCentred.Top)
rectCentred.Top = rectCentred.Top + lOffset
rectCentred.bottom = rectCentred.bottom + lOffset
End If
If (rectCentred.bottom > rectWork.bottom) Then
lOffset = (rectCentred.bottom - rectWork.bottom)
rectCentred.Top = rectCentred.Top - lOffset
rectCentred.bottom = rectCentred.bottom - lOffset
End If
' Move:
MoveWindow hwnd, rectCentred.Left, rectCentred.Top, _
rectCentred.right - rectCentred.Left, _
rectCentred.bottom - rectCentred.Top, _
1
' Finished subclassing & Hooking:
DetachMessage Me, hwnd, WM_INITDIALOG
RemoveHook Me, WH_CBT
m_bHook = False
End Function
Private Function IWindowsHook_HookProc(ByVal eType As
vbalWinHook6.EHTHookTypeConstants, ByVal nCode As Long, ByVal wParam As Long,
ByVal lParam As Long, bConsume As Boolean) As Long
If eType = WH_CBT Then
If nCode = HCBT_CREATEWND Then
InstallWinProc wParam
End If
End If
End Function
Private Function InstallWinProc(ByVal hwnd As Long)
Dim lProcOld As Long
Dim sClass As String
Dim iPos As Long
If IsValidLocalWindow(hwnd) Then
If (InStr(ClassName(hwnd), "#32770")) Then
AttachMessage Me, hwnd, WM_INITDIALOG
End If
End If
End Function
Private Function IsValidLocalWindow(ByVal hwnd As Long) As Boolean
If IsWindow(hwnd) Then
Dim idWnd As Long
Call GetWindowThreadProcessId(hwnd, idWnd)
IsValidLocalWindow = (idWnd = GetCurrentProcessId())
End If
End Function
Private Property Get ClassName(ByVal hwnd As Long) As String
Dim sBuf As String
Dim iPos As Long
sBuf = String$(255, 0)
GetClassName hwnd, sBuf, 255
iPos = InStr(sBuf, Chr$(0))
If iPos > 1 Then
ClassName = Left$(sBuf, iPos - 1)
End If
End Property
|
|