popmenu.bas

adsl拨号工具 有很多功能 不错啊 大家试试

Attribute VB_Name = "PopMenu"
'****************************************************************************
'人人为我，我为人人
'枕善居汉出品
'发布日期：05/08/15
'描  述：拨号上网管理器
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
Declare Function CreatePopupMenu Lib "user32" () As Long

Declare Function TrackPopupMenu Lib "user32" _
        (ByVal hMenu As Long, _
        ByVal wFlags As Long, _
        ByVal X As Long, _
        ByVal Y As Long, _
        ByVal nReserved As Long, _
        ByVal hwnd As Long, _
        ByVal lprc As Any) As Long
        
Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" _
        (ByVal hMenu As Long, _
        ByVal wFlags As Long, _
        ByVal wIDNewItem As Long, _
        ByVal lpNewItem As Any) As Long
        
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _
        (ByVal hMenu As Long, _
        ByVal nPosition As Long, _
        ByVal wFlags As Long, _
        ByVal wIDNewItem As Long, _
        ByVal lpString As Any) As Long
        
Public Declare Function DestroyMenu Lib "user32" _
        (ByVal hMenu As Long) As Long
        
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Declare Function BitBlt Lib "gdi32" _
        (ByVal hDestDC As Long, _
        ByVal X As Long, _
        ByVal Y As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal hSrcDC As Long, _
        ByVal xSrc As Long, _
        ByVal ySrc As Long, _
        ByVal dwRop As Long) As Long

Declare Function SetRect Lib "user32" (lpRect As RECT, _
        ByVal X1 As Long, _
        ByVal Y1 As Long, _
        ByVal X2 As Long, _
        ByVal Y2 As Long) As Long

Declare Function DrawCaption Lib "user32" _
        (ByVal hwnd As Long, _
        ByVal hDC As Long, _
        pcRect As RECT, _
        ByVal un As Long) As Long
        
Declare Function GetMenuItemRect Lib "user32" _
        (ByVal hwnd As Long, ByVal hMenu As Long, _
        ByVal uItem As Long, _
        lprcItem As RECT) As Long

Declare Function GetMenuItemCount Lib "user32" _
        (ByVal hMenu As Long) As Long

Declare Function GetPixel Lib "gdi32" _
        (ByVal hDC As Long, _
        ByVal X As Long, _
        ByVal Y As Long) As Long
        
Declare Function SetPixel Lib "gdi32" _
        (ByVal hDC As Long, _
        ByVal X As Long, _
        ByVal Y As Long, _
        ByVal crColor As Long) As Long

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

Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type

Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    hDC As Long
    rcItem As RECT
    itemData As Long
End Type

Public Type POINTAPI
    X As Long
    Y As Long
End Type

Const MF_APPEND = &H100&
Const MF_BYCOMMAND = &H0&
Const MF_BYPOSITION = &H400&
Const MF_DEFAULT = &H1000&
Const MF_DISABLED = &H2&
Const MF_ENABLED = &H0&
Const MF_GRAYED = &H1&
Const MF_MENUBARBREAK = &H20&
Const MF_OWNERDRAW = &H100&
Const MF_POPUP = &H10&
Const MF_REMOVE = &H1000&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const MF_UNCHECKED = &H0&
Const MF_BITMAP = &H4&
Const MF_USECHECKBITMAPS = &H200&

Public Const MF_CHECKED = &H8&
Public Const MFT_RADIOCHECK = &H200&

Const TPM_RETURNCMD = &H100&

Const DC_GRADIENT = &H20
Const DC_ACTIVE = &H1
Const DC_ICON = &H4
Const DC_SMALLCAP = &H2
Const DC_TEXT = &H8

Public hMenu As Long
Public hSubmenu As Long
Public chkMnuFlags(2) As Long
Public MP As POINTAPI, sMenu As Long
Public mnuHeight As Single

Public Sub MeasureMenu(ByRef lP As Long)
    
    'It would appear that you cannot actually get measurements here,
    'you can only set them. There are no measurements until after the
    'Menu is drawn, but you only get a WM_MEASUREITEM message before the
    'initial WM_DRAWITEM.
    
    Dim MIS As MEASUREITEMSTRUCT
    'Load MIS with that in memory
    CopyMemory MIS, ByVal lP, Len(MIS)
        MIS.itemWidth = 5   '(18 - 1) - 12. I don't know where the 12 comes
        'from, but there always seems to be 12 pixels more than I want.
        '18 is Small Titlebar height.
    
    'Return the updated MIS
    CopyMemory ByVal lP, MIS, Len(MIS)
    
End Sub

Public Sub DrawMenu(ByRef lP As Long)
    
    Dim DIS As DRAWITEMSTRUCT, rct As RECT, lRslt As Long
    
    CopyMemory DIS, ByVal lP, Len(DIS)
    
    With AppForm
        'since we can't measure in the MeasureMenu sub we'll do it here.
        'we cannot just get the sidebar height as it will only return
        'the height of an empty menu item. (i.e. 13). Maybe we can get the
        'height of the whole menu with some other API call that I don't know
        'about. I tried GetWindowRect.
        
        'String Menus
        GetMenuItemRect .hwnd, hMenu, 1, rct
        mnuHeight = (rct.Bottom - rct.Top) * (GetMenuItemCount(hMenu) - GetMenuItemCount(hSubmenu) - 1)
        'Separators
        GetMenuItemRect .hwnd, hMenu, 3, rct
        mnuHeight = mnuHeight + (rct.Bottom - rct.Top) * 2 '2 Seperators
        
        'set the size of our sidebar
        SetRect rct, 0, 0, mnuHeight, 18
        
        'This is a bit of a copout, but it works
        'You could always use GradientFillRect and then draw rotated text
        'straight onto the sidebar, but this is much easier
        'you could use a hidden picturebox for this
        'Draw a form caption onto our userform, the length of our menu height
        DrawCaption .hwnd, .hDC, rct, DC_SMALLCAP Or DC_ACTIVE Or DC_TEXT Or DC_GRADIENT
        
        Dim X As Single, Y As Single
        Dim nColor As Long
        
        'rotate our caption through 270 degrees
        'and paint onto menu
        For X = 0 To mnuHeight
            For Y = 0 To 17
                nColor = GetPixel(.hDC, X, Y)
                SetPixel DIS.hDC, Y, mnuHeight - X, nColor
            Next Y
        Next X
        'that rotation was simple.
        'I don't know why the msdn article was so complex.
        
        'remove the caption picture from the user form
        .Cls
        'Hopefully this operation was so fast that you did'nt see it happen.
     End With

End Sub

Public Sub MenuPopUp()
    'create the menu
    hMenu = CreatePopupMenu()
    hSubmenu = CreatePopupMenu()
    
    AppendMenu hMenu, MF_OWNERDRAW Or MF_DISABLED, 1000, 0&    '垂直边
    AppendMenu hMenu, MF_POPUP Or MF_MENUBARBREAK, hSubmenu, "插    件"
'    AppendMenu hMenu, MF_SEPARATOR, 0&, 0&
    If frmDialupManage.WindowState = 1 Then
       AppendMenu hMenu, 0&, 1100, "显示界面(&M)"     'MF_GRAYED
    Else
       AppendMenu hMenu, MF_GRAYED, 1100, "显示界面(&M)"     'MF_GRAYED
    End If
    AppendMenu hMenu, MF_SEPARATOR, 0&, 0&
    AppendMenu hMenu, 0&, 1200, "查看记录(&V)"     'MF_GRAYED
    AppendMenu hMenu, 0&, 1300, "打印记录(&P)"    'chkMnuFlags(2)
    'AppendMenu hMenu, MF_SEPARATOR, 0&, 0&
    AppendMenu hMenu, 0&, 1400, "参数设置(&S)"
    AppendMenu hMenu, 0&, 1500, "关于程序(&A)"
    
    AppendMenu hMenu, MF_SEPARATOR, 0&, 0&
    If frmDialupManage.rasDialer.Connected Then
       AppendMenu hMenu, 0&, 2000, "断线下网(&H)"
    Else
       AppendMenu hMenu, MF_GRAYED, 2000, "断线下网(&H)"
    End If
    AppendMenu hMenu, 0&, 2100, "退出程序(&E)"
    
    AppendMenu hSubmenu, chkMnuFlags(0), 1101, "网络流量计(&D)"
    AppendMenu hSubmenu, chkMnuFlags(1), 1102, "邮件检查(&C)"
    
 End Sub

Public Sub MenuTrack(frm As Form)
    
    GetCursorPos MP
    
    sMenu = TrackPopupMenu(hMenu, TPM_RETURNCMD, MP.X, MP.Y, 0, frm.hwnd, 0&)
    'check for clicks
    Select Case sMenu
        Case 1101
            If chkMnuFlags(0) = 0 Then
                chkMnuFlags(0) = MFT_RADIOCHECK Or MF_CHECKED
                chkMnuFlags(1) = 0&
            End If
        Case 1102
            If chkMnuFlags(1) = 0 Then
                chkMnuFlags(1) = MFT_RADIOCHECK Or MF_CHECKED
                chkMnuFlags(0) = 0&
            End If
        Case 1100
            MenuPopUp
            frmDialupManage.WindowState = vbNormal
            frmDialupManage.Show
            App.TaskVisible = True
        Case 1200
            FrmViewRecord.Show vbModal
        Case 1300
            MsgBox "[打印记录] 正在制作中..."
        Case 1400
            Call frmDialupManage.Sett
        Case 1500
            ShellAbout hwnd, "上网管理器 v1.0#(c)  作者:马相赋 2002-2005", "  适用于中小企业、家庭、学校上网管理用,可自动记录拨号信息,控制非法上网.", Icon
        Case 2000
             Call frmDialupManage.HangUpNet
             Call frmDialupManage.UpDateInfo
             frmDialupManage.WindowState = vbNormal
             frmDialupManage.Show
             App.TaskVisible = True
        Case 2100
            UnHook
            Unload AppForm
            Exit Sub
    End Select
    
    'update checked menu items
    ModifyMenu hMenu, 1101, chkMnuFlags(0), 1101, "网速流量计"
    ModifyMenu hMenu, 1102, chkMnuFlags(1), 1102, "邮件检查(&C)"
    
'    If sMenu <> 0 Then frm.Print sMenu
    
End Sub

'用法： Alert frmpop,Text1.Text, 3000
'最好加入置前功能
Public Sub Alert(Popfrm As Object, Text As String, DelyTime As Long)
    Dim AlertBox As frmAlert
    Set AlertBox = New frmAlert
    AlertBox.DisplayAlert Text, DelyTime
    Popfrm.SetFocus
End Sub