basother.bas

用VB6.0编写的QQ聊天软件

Attribute VB_Name = "basOther"
Option Explicit

Public tkPower As Integer           ' 管理员权限
Public tkNoPopup As Boolean         ' 是否显示弹出菜单
Public tkLogin As Boolean           ' 是否正在登录
Public tkSearchContext As String    ' 查找字串
Public tkSearchWhole As Integer     ' 是否匹配全单词
Public tkSearchSubField As Integer  ' 查找范围
Public tkUserID As String           ' 查看用户资料
Public tkViewFriend As Boolean      ' 是否正在查看好友

Public tkModify As Integer          ' 修改操作
Public tkCursor As Long             ' 加载的外部动画光标

Public prevWndProc As Long

Public Const ID_NULL = vbNullString
Public Const ID_SHOWWINDOW = "显示窗体(&S)"
Public Const ID_SEPARATOR = "-"
Public Const ID_ADMINADD = "添加管理员(&A)"
Public Const ID_ADMINDELETE = "删除管理员(&D)"
Public Const ID_ADMINMODIFY = "修改管理员(&M)"
Public Const ID_USERADD = "添加用户(&A)"
Public Const ID_USERDELETE = "删除用户(&D)"
Public Const ID_USERMODIFY = "修改用户(&M)"
Public Const ID_HELP = "帮助(&H)"
Public Const ID_HELPTHEME = "帮助主题(&H)"
Public Const ID_ABOUT = "关于(&A)..."
Public Const ID_LEAVE = "离开(&L)"

Public Const TK_SHOWWINDOW = 2
Public Const TK_ADMINADD = 4
Public Const TK_ADMINDELETE = 5
Public Const TK_ADMINMODIFY = 6
Public Const TK_USERADD = 8
Public Const TK_USERDELETE = 9
Public Const TK_USERMODIFY = 10
Public Const TK_LEAVE = 14
Public Const TK_HELPTHEME = 15
Public Const TK_ABOUT = 17



Public Function WndProc( _
        ByVal hwnd As Long, _
        ByVal Msg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long _
    ) As Long
    
    Dim m_frRect As RECT
    Dim m_deRect As RECT
    
    Select Case Msg
        Case WM_NOTIFYICON
            Select Case lParam
                Case WM_LBUTTONDBLCLK
                    tkShowWindow hwnd
                Case WM_RBUTTONUP
                    If tkNoPopup = False And frmMain.pbStatus.Value = 0 And tkViewFriend = False Then
                        tkPopupMenu hwnd
                    End If
            End Select
        Case WM_GETMINMAXINFO
            Dim tkMin As MINMAXINFO
            CopyMemory tkMin, ByVal lParam, Len(tkMin)
            tkMin.ptMinTrackSize.x = 515
            tkMin.ptMinTrackSize.y = 400
            CopyMemory ByVal lParam, tkMin, Len(tkMin)
        Case WM_DRAWITEM
            Dim lpDrawInfo As DRAWITEMSTRUCT
            CopyMemory lpDrawInfo, ByVal lParam, Len(lpDrawInfo)
            Select Case lpDrawInfo.itemID
                Case 18
                    StretchBlt lpDrawInfo.hdc, 0, 0, _
                        frmMain.picMenu.ScaleWidth, _
                        lpDrawInfo.rcItem.Bottom, _
                        frmMain.picMenu.hdc, 0, 0, _
                        frmMain.picMenu.ScaleWidth, _
                        frmMain.picMenu.ScaleHeight, _
                        vbSrcCopy
            End Select
        Case WM_MEASUREITEM
            Dim lpMeasureInfo As MEASUREITEMSTRUCT
            CopyMemory lpMeasureInfo, ByVal lParam, Len(lpMeasureInfo)
            With lpMeasureInfo
                If .itemID = 0 Then
                    .itemWidth = 8
                End If
                If .itemID = 18 Then
                    .itemHeight = 0
                End If
            End With
            CopyMemory ByVal lParam, lpMeasureInfo, Len(lpMeasureInfo)
        Case Else
            WndProc = CallWindowProc(prevWndProc, hwnd, Msg, wParam, lParam)
    End Select
    
End Function

Public Sub tkSetRadio( _
        tkForm As Form, _
        tkMenuItem As Integer, _
        tkCaption As String, _
        tkSubMenuItem As Integer _
    )

    ' 菜单句柄及信息
    Dim tkMenu As Long
    Dim tkInfo As MENUITEMINFO
    
    ' 获取菜单句柄
    tkMenu = GetMenu(tkForm.hwnd)
    tkMenu = GetSubMenu(tkMenu, tkMenuItem)
    
    ' 设置菜单参数
    With tkInfo
        .fMask = MIIM_TYPE
        .fType = MFT_RADIOCHECK
        .dwTypeData = tkCaption
        .cbSize = Len(tkInfo)
    End With
    
    ' 在菜单项前增加一个圆型标志
    SetMenuItemInfo tkMenu, _
        tkSubMenuItem, _
        True, _
        tkInfo

End Sub

Public Sub tkPopupMenu(hwnd As Long)
    Dim hMainMenu As New clsPopMenu
    Dim retMenu As Integer
    
    SetForegroundWindow hwnd
    retMenu = hMainMenu.Popup(ID_NULL, _
                    ID_SHOWWINDOW, _
                    ID_SEPARATOR, _
                    ID_ADMINADD, _
                    ID_ADMINDELETE, _
                    ID_ADMINMODIFY, _
                    ID_SEPARATOR, _
                    ID_USERADD, _
                    ID_USERDELETE, _
                    ID_USERMODIFY, _
                    ID_SEPARATOR, _
                    ID_HELP, _
                    ID_SEPARATOR, _
                    ID_LEAVE)
    Select Case retMenu
        Case TK_SHOWWINDOW
            tkShowWindow hwnd
        Case TK_ABOUT
            ShellAbout hwnd, _
                    frmMain.Caption, _
                    "孙建华" & vbCrLf & "[e-mail]", _
                    tkCursor
        Case TK_ADMINADD, _
                TK_ADMINDELETE, _
                TK_ADMINMODIFY
            tkShowWindow hwnd
            tkModify = retMenu - 4
            frmEdit.Show vbModal
        Case TK_USERADD, _
                TK_USERDELETE, _
                TK_USERMODIFY
            tkShowWindow hwnd
            tkModify = retMenu - 5
            frmEdit.Show vbModal
        Case TK_LEAVE
            Unload frmMain
    End Select

    Set hMainMenu = Nothing
End Sub

Public Sub tkShowWindow(hwnd As Long)
    ' 将窗体置为最前并显示
    SetForegroundWindow hwnd
    ShowWindow hwnd, SW_RESTORE
End Sub

Public Sub ExtractFile(tkResID As String, _
        tkResType As String, _
        tkFileName As String _
    )
    
    Dim tkFileNum As Byte
    Dim tkData() As Byte
    tkData = LoadResData(tkResID, tkResType)
    tkFileNum = FreeFile()
    Open tkFileName For Binary As #tkFileNum
    Put #tkFileNum, , tkData()
    Close #tkFileNum
    
End Sub