Find all our projects in development below.
All source code is GNU General Public License (GPL)

QuickQuery Half-Life Edition

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

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

    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)
    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
    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)
        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
                ElseIf wParam = ShowRCONCmdsMenuID Then
                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