modinterface.bas

排队分诊管理系统源代码！该代码使用VB6开发环境

Attribute VB_Name = "modInterface"
Option Explicit

Public Const HWND_TOPMOST = -1

Public procOld              As Long     '保持原来的系统菜单处理函数的句柄

Type POINTAPI
    X As Long
    Y As Long
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Is_Move_B            As Boolean '判断指针是否位于移动栏(本例中移动栏位于窗体的侧一小地方)
Public Is_Movestar_B        As Boolean '判断移动是否开始
Public MyRect               As RECT
Public MyPoint              As POINTAPI
Public Movex                As Long, Movey As Long  '记录窗体移动前，窗体左上角与鼠标指针位置间的纵横距离
Public max                  As Long   '窗口变长以后的尺寸(用户可随意改动)

'获得鼠标指针在屏幕坐标上的位置
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'获得窗口在屏幕坐标中的位置
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
'判断指定的点是否在指定的巨型内部
Public Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long) As Long
'准备用来使窗体始终在最前面
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter _
            As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'用来移动窗体
Public 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 Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_DRAWFRAME = &H20
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME = &H40000
Private Const WS_DLGFRAME = &H400000
Private Const WS_POPUP = &H80000000
Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MAXIMIZE = &H1000000

Public 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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
            (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
            (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'以下为窗口常用消息
Private Const SC_SIZE = &HF000&
Private Const SC_MOVE = &HF010&
Private Const SC_MINIMIZE = &HF020&
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_NEXTWINDOW = &HF040&
Private Const SC_PREVWINDOW = &HF050&
Private Const SC_CLOSE = &HF060&
Private Const SC_VSCROLL = &HF070&
Private Const SC_HSCROLL = &HF080&
Private Const SC_MOUSEMENU = &HF090&
Private Const SC_KEYMENU = &HF100&
Private Const SC_ARRANGE = &HF110&
Private Const SC_RESTORE = &HF120&
Private Const SC_TASKLIST = &HF130&
Private Const SC_SCREENSAVE = &HF140&
Private Const SC_HOTKEY = &HF150&

Private Const WM_SYSCOMMAND = &H112
Private Const WM_USER = &H400
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_MOVE = &H3
Private Const WM_EXITSIZEMOVE = &H232

Public Const GWL_WNDPROC = (-4)

Public Sub Get_Windows_Rect()
    On Error Resume Next
    Dim dl As Integer
    
    max = 690
    frmQueue.Height = max
    frmQueue.Top = 0       '窗体始终放在屏幕顶部
    dl = GetWindowRect(frmQueue.hWnd, MyRect)
End Sub

Public Sub ControlWindows(SetTrue As Boolean)
    On Error Resume Next
    Dim dwStyle As Long
    
    dwStyle = GetWindowLong(frmQueue.hWnd, GWL_STYLE)
    If SetTrue = False Then
        dwStyle = dwStyle Or WS_SYSMENU Or WS_CAPTION Or WS_MINIMIZEBOX
        frmQueue.Height = 1065
    Else
        dwStyle = dwStyle - WS_SYSMENU - WS_CAPTION - WS_MINIMIZEBOX
        frmQueue.Height = 690
    End If
    dwStyle = SetWindowLong(frmQueue.hWnd, GWL_STYLE, dwStyle)
    SetWindowPos frmQueue.hWnd, 0, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub

'以下为窗口系统消息相应函数
Public Function SysMenuProc(ByVal hWnd As Long, ByVal iMsg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    Dim bStatus As Boolean, dl As Integer
     
    bStatus = False
    ' Ignore everything but system commands
    Select Case iMsg
        Case WM_SYSCOMMAND
            ' Check for one special menu item
            Select Case wParam
                Case SC_CLOSE
                    bStatus = True
                Case Else
                    bStatus = False
            End Select
        Case WM_EXITSIZEMOVE
            If frmQueue.m_bDock = False Then
                dl = GetWindowRect(frmQueue.hWnd, MyRect)
                If MyRect.Top < 20 Then
                    frmQueue.m_bDock = True
                    frmQueue.timStart.Enabled = True
                    modInterface.ControlWindows frmQueue.m_bDock
                    
                    Get_Windows_Rect
                    Is_Movestar_B = False
                    SysMenuProc = 0
                    Exit Function
                Else
                    bStatus = False
                End If
            Else
                bStatus = False
            End If
    End Select
    
    If bStatus = False Then
        ' Let old window procedure handle other messages
        SysMenuProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)
    Else
        If frmQueue.cmdQuit.Enabled = True Then
            frmQueue.m_bReLogin = False
            Unload frmQueue
        End If
        SysMenuProc = 0
    End If
End Function