Projects

QuickQuery Half-Life Edition

April 11, 2007 by Java

Browsing QuickQuery HL Edition/FormSizingMod.bas (4.39 KB)

Attribute VB_Name = "FormSizingMod"
Option Explicit

Private Const GWL_WNDPROC = (-4)
Private Const WM_GETMINMAXINFO = &H24
Private Const WM_SYSCOMMAND = &H112

Public Const ClearRCONBufMenuID = 2031
Public Const ShowRCONCmdsMenuID = 2032

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MINMAXINFO
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinTrackSize As POINTAPI
    ptMaxTrackSize As POINTAPI
End Type

Private Type WINDOWBOUNDS
    FixForm As Form
    hWnd As Long
    minX As Long
    minY As Long
    maxX As Long
    maxY As Long
    defProc As Long
End Type

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 wBounds() As WINDOWBOUNDS

Public Sub FixSize(ByVal FixForm As Form, minX As Long, minY As Long, maxX As Long, maxY As Long)
Dim tWB As WINDOWBOUNDS
    Set tWB.FixForm = FixForm
    tWB.hWnd = FixForm.hWnd
    tWB.minX = minX / Screen.TwipsPerPixelX
    tWB.minY = minY / Screen.TwipsPerPixelY
    tWB.maxX = maxX / Screen.TwipsPerPixelX
    tWB.maxY = maxY / Screen.TwipsPerPixelY
    On Error Resume Next
    ReDim Preserve wBounds(UBound(wBounds) + 1)
    If Err Then ReDim wBounds(1)
    If tWB.FixForm.Name <> MainForm.Name Then tWB.defProc = SubClass(tWB.hWnd)
    wBounds(UBound(wBounds)) = tWB
End Sub


Private Function SubClass(hWnd As Long) As Long
Dim defWindowProc As Long
On Error Resume Next
    defWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf FSMWindowProc)
    SubClass = defWindowProc
End Function


Public Sub UnfixSize(ByVal FixForm As Form)
On Error Resume Next
Dim i As Integer, wbInfo As WINDOWBOUNDS, found As Integer
    found = -1
    For i = 1 To UBound(wBounds)
    If wBounds(i).hWnd = FixForm.hWnd Then
            wbInfo = wBounds(i)
            found = i
        End If
    Next
    If found <> -1 Then
        UnSubClass FixForm.hWnd, wbInfo.defProc
        If found < UBound(wBounds) Then
            For i = found To UBound(wBounds) - 1
                wBounds(i) = wBounds(i + 1)
            Next
        End If
        ReDim Preserve wBounds(UBound(wBounds) - 1)
    End If
End Sub


Public Sub UnfixSizeAll()
On Error Resume Next
    If UBound(wBounds) < 1 Then Exit Sub
    If Err <> 0 Then Exit Sub
    Dim i As Integer
    For i = 1 To UBound(wBounds)
        If wBounds(i).hWnd > 0 Then UnSubClass wBounds(i).hWnd, wBounds(i).defProc
    Next i
    ReDim wBounds(0)
End Sub


Private Sub UnSubClass(hWnd As Long, PrevDefProc As Long)
    SetWindowLong hWnd, GWL_WNDPROC, PrevDefProc
End Sub


Public Function FSMWindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim i As Integer, bWndFound As Boolean, wbInfo As WINDOWBOUNDS
On Error Resume Next
    For i = 1 To UBound(wBounds)
        If wBounds(i).hWnd = hWnd Then
            bWndFound = True
            wbInfo = wBounds(i)
            Exit For
        End If
    Next i
    If bWndFound Then
        Select Case uMsg
            Case WM_GETMINMAXINFO
                Dim MMI As MINMAXINFO
                CopyMemory MMI, ByVal lParam, LenB(MMI)
                With MMI
                    .ptMinTrackSize.x = wbInfo.minX
                    .ptMinTrackSize.y = wbInfo.minY
                    .ptMaxTrackSize.x = wbInfo.maxX
                    .ptMaxTrackSize.y = wbInfo.maxY
                End With
                CopyMemory ByVal lParam, MMI, LenB(MMI)
                FSMWindowProc = 0
                Exit Function
            Case WM_SYSCOMMAND
                If wParam = ClearRCONBufMenuID Then
                    wbInfo.FixForm.ClearRCONBuffer
                ElseIf wParam = ShowRCONCmdsMenuID Then
                    wbInfo.FixForm.ShowRCONCmds
                End If
        End Select
        If wbInfo.FixForm.Name <> MainForm.Name Then _
            FSMWindowProc = CallWindowProc(wbInfo.defProc, hWnd, uMsg, wParam, lParam)
    End If
End Function

Download QuickQuery HL Edition/FormSizingMod.bas

Back to file list

---

Back to project page