mod_restrictsize.bas

农村水电费记帐录入

Attribute VB_Name = "mod_restrictsize"

Option Explicit

'***********************************
'全局API声明
'***********************************
    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 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 startupheight As Long
    Private startupwidth As Long

'***********************************
'全局变量
'***********************************
    Private defWindowProc As Long
    Private minX As Long
    Private minY As Long
    Private maxX As Long
    Private maxY As Long

'***********************************
'全局常数
'***********************************
    Private Const WM_GETMINMAXINFO As Long = &H24
    Private Const GWL_WNDPROC = (-4)

'***********************************
'类型声明
'***********************************
    '全局
    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

'***********************************
'用户接口
'***********************************
    '-------------------------------
    '窗体约束
    '-------------------------------
    Public Sub restrictform(resrictform As Form)
        Dim startupwidth As Long
        Dim startupheight As Long
        With resrictform
            startupwidth = .width \ Screen.TwipsPerPixelX
            startupheight = .height \ Screen.TwipsPerPixelY
            minX = startupwidth
            minY = startupheight
            maxX = Screen.width \ Screen.TwipsPerPixelX
            maxY = Screen.height \ Screen.TwipsPerPixelY
            SubClass .hwnd
        End With
    End Sub

    '-------------------------------
    '窗体释放
    '-------------------------------
    Public Sub unrestrictform(restrictform As Form)
        UnSubClass restrictform.hwnd
    End Sub

'***********************************
'子集
'***********************************
    '-------------------------------
    '开始子集
    '-------------------------------
    Private Sub SubClass(hwnd As Long)
        On Error Resume Next
        defWindowProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
    End Sub
    
    '-------------------------------
    '结束子集
    '-------------------------------
    Private Sub UnSubClass(hwnd As Long)
        If defWindowProc Then
            SetWindowLong hwnd, GWL_WNDPROC, defWindowProc
            defWindowProc = 0
        End If
    End Sub

'***********************************
'窗体缩放程序
'***********************************
    Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Select Case uMsg
            Case WM_GETMINMAXINFO
                Dim MMI As MINMAXINFO
                CopyMemory MMI, ByVal lParam, LenB(MMI)
                With MMI
                    .ptMinTrackSize.x = minX
                    .ptMinTrackSize.y = minY
                    .ptMaxTrackSize.x = maxX
                    .ptMaxTrackSize.y = maxY
                End With
                CopyMemory ByVal lParam, MMI, LenB(MMI)
                WindowProc = 0
            Case Else
                WindowProc = CallWindowProc(defWindowProc, hwnd, uMsg, wParam, lParam)
        End Select
    End Function