vbAccelerator - Contents of code file: cDialogCentre.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
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 SSubTimer.EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As SSubTimer.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
 vbalWinHook.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