www.pudn.com > QQ2009.rar > frmMenu.frm, change:2009-11-15,size:9731b


VERSION 5.00 
Begin VB.Form frmMenu  
   AutoRedraw      =   -1  'True 
   BackColor       =   &H00FF00FF& 
   BorderStyle     =   0  'None 
   Caption         =   "Menu" 
   ClientHeight    =   3090 
   ClientLeft      =   0 
   ClientTop       =   0 
   ClientWidth     =   4680 
   LinkTopic       =   "Form1" 
   ScaleHeight     =   206 
   ScaleMode       =   3  'Pixel 
   ScaleWidth      =   312 
   ShowInTaskbar   =   0   'False 
   Begin VB.Timer timMouse  
      Enabled         =   0   'False 
      Interval        =   1 
      Left            =   2280 
      Top             =   1560 
   End 
   Begin VB.Label lblC  
      BackStyle       =   0  'Transparent 
      Height          =   375 
      Index           =   0 
      Left            =   840 
      TabIndex        =   0 
      Top             =   480 
      Width           =   1695 
   End 
End 
Attribute VB_Name = "frmMenu" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = False 
Attribute VB_PredeclaredId = True 
Attribute VB_Exposed = False 
 
Option Explicit 
 
Public CallBack As Form 
 
Dim Menu() As MenuItem, MenuCount As Long 
 
Dim MenuID As Long 
Dim OverIndex As Long 
 
Dim fH As Long, fW As Long 
 
Dim bBg As Long, bHl As Long, bSp As Long 
Dim bT_n As Long, bT_o As Long 
Dim fontFamily As Long, cFont As Long, strFormat As Long 
 
Dim graphics As Long 
 
Private Sub SetOverIndex(ByVal Index As Long) 
    If OverIndex <> Index Then 
        OverIndex = Index 
        Redraw 
    End If 
End Sub 
 
Public Sub InitMenu(ByVal MenuListID As Long, Optional ByVal MenuWidth As Long = 109) 
    fW = MenuWidth: fH = 3 
    OverIndex = -1 
    MenuID = MenuListID 
End Sub 
 
Public Sub AddMenu(ByVal itemID As Long, ByVal ItemType As MenuItemType, Optional ByVal Caption As String, Optional ByVal Icon As Long, Optional ByVal IconW As Long, Optional ByVal IconH As Long) 
    ReDim Preserve Menu(MenuCount) 
     
    With Menu(MenuCount) 
        .ID = itemID 
        .ItemType = ItemType 
         
        If ItemType = NormalItem Then 
            .RECT.Left = 38: .RECT.Right = fW - 6: .RECT.Top = fH + 4: .RECT.Bottom = 22 
             
            If MenuCount > 0 Then Load lblC(MenuCount) 
            lblC(MenuCount).Move 3, fH, fW - 6, 22 
            lblC(MenuCount).Visible = True 
             
            .Caption = Caption 
            .CaptionLength = Len(Caption) 
             
            If Icon <> 0 Then 
                .Icon.Icon = Icon 
                .Icon.Width = IconW 
                .Icon.Height = IconH 
            End If 
 
            fH = fH + 22 
        Else 
            .RECT.Top = fH 
            fH = fH + 4 
        End If 
    End With 
         
    MenuCount = MenuCount + 1 
End Sub 
 
Public Sub ShowMenu(Optional ByVal x As Single, Optional ByVal y As Single, Optional ByVal OutSkip As Single) 
    fH = fH + 3 
     
    Dim g As Long 
     
    Dim path As Long, pen As Long 
    Dim brush1 As Long, brush2 As Long 
    Dim p1 As POINTF, p2 As POINTF, blend(2) As Single, colors(2) As Single 
 
    Me.Width = fW * tX 
    Me.Height = fH * tY 
     
    '------------------------------------- 
    'Background Bitmap 
    GdipCreateBitmapFromScan0 fW, fH, 0, GpPixelFormat.PixelFormat32bppARGB, ByVal 0, bBg 
    GdipGetImageGraphicsContext bBg, g 
    p1.x = 0: p1.y = 3 
    p2.x = 0: p2.y = fH - 3 
     
    CreateRoundRectPath 0, 0, fW, fH, 10, path 
    GdipCreateSolidFill &HFF19555F, brush1 
    GdipCreatePen1 &HFF19555F, 1, UnitPixel, pen 
    GdipFillPath g, brush1, path 
    GdipDrawPath g, pen, path 
    GdipDeleteBrush brush1 
    GdipDeletePath path 
     
    GdipCreateLineBrush p1, p2, &HFFCCE9FD, &HFFB7DEF9, WrapModeTileFlipY, brush1 
    GdipCreateLineBrush p1, p2, &HFFEDF6FE, &HFFD9EEFB, WrapModeTileFlipY, brush2 
    GdipFillRectangleI g, brush1, 3, 3, fW - 6, fH - 6 
    GdipFillRectangleI g, brush2, 29, 3, fW - 32, fH - 6 
    GdipDeleteBrush brush1 
    GdipDeleteBrush brush2 
     
    GdipSetSmoothingMode g, SmoothingModeAntiAlias 
     
    CreateRoundRectPath 1, 1, fW - 2, fH - 2, 8, path 
    GdipSetPenColor pen, &HFF89D6FF 
    GdipDrawPath g, pen, path 
    GdipDeletePath path 
     
    CreateRoundRectPath 2, 2, fW - 4, fH - 4, 6, path 
    GdipSetPenColor pen, &HFFFFFFFF 
    GdipDrawPath g, pen, path 
    GdipDeletePath path 
     
    GdipDeletePen pen 
    GdipDeleteGraphics g 
     
    '------------------------------------- 
    'Item hover Bitmap 
    GdipCreateBitmapFromScan0 fW - 6, 22, 0, GpPixelFormat.PixelFormat32bppARGB, ByVal 0, bHl 
    GdipGetImageGraphicsContext bHl, g 
    p1.x = 0: p1.y = 0 
    p2.x = 0: p2.y = 22 
     
    GdipSetSmoothingMode g, SmoothingModeAntiAlias 
     
    CreateRoundRectPath 0, 0, fW - 6, 22, 4, path 
    GdipCreateLineBrush p1, p2, &HFF00B9ED, &HFF009CD7, WrapModeTileFlipY, brush1 
    GdipCreatePen2 brush1, 1, UnitPixel, pen 
     
    GdipFillPath g, brush1, path 
    GdipDrawPath g, pen, path 
     
    GdipDeletePath path 
    GdipDeleteBrush brush1 
    GdipDeletePen pen 
    GdipDeleteGraphics g 
     
    '------------------------------------- 
    'Split line 
    GdipCreateBitmapFromScan0 fW - 32, 4, 0, GpPixelFormat.PixelFormat32bppARGB, ByVal 0, bSp 
    GdipGetImageGraphicsContext bSp, g 
    p1.x = 0: p1.y = 0 
    p2.x = fW / 2 - 16: p2.y = 0 
    blend(0) = 0: blend(1) = 0.5: blend(2) = 1 
     
    colors(0) = &HB2DEF6: colors(1) = &HFFB2DEF6: colors(2) = &HB2DEF6 
    GdipCreateLineBrush p1, p2, &HB2DEF6, &HFFB2DEF6, WrapModeTileFlipX, brush1 
    GdipSetLinePresetBlend brush1, VarPtr(blend(0)), VarPtr(colors(0)), 3 
     
    colors(0) = &HFEFFF: colors(1) = &HFFFEFFF: colors(2) = &HFEFFF 
    GdipCreateLineBrush p1, p2, &HFEFFFF, &HFFFEFFFF, WrapModeTileFlipX, brush2 
    GdipSetLinePresetBlend brush2, VarPtr(blend(0)), VarPtr(colors(0)), 3 
     
    GdipFillRectangleI g, brush1, 0, 1, fW - 32, 1 
    GdipFillRectangleI g, brush2, 0, 2, fW - 32, 1 
     
    GdipDeleteBrush brush1 
    GdipDeleteBrush brush2 
    GdipDeleteGraphics g 
     
    '------------------------------------- 
    'Fonts 
    GdipCreateSolidFill &HFF001524, bT_n 
    GdipCreateSolidFill &HFFFFFFFF, bT_o 
    GdipCreateFontFamilyFromName StrPtr("Verdana"), 0, fontFamily 
    GdipCreateFont fontFamily, 11, FontStyle.FontStyleRegular, UnitPixel, cFont 
    GdipCreateStringFormat 0, 0, strFormat 
    GdipSetStringFormatAlign strFormat, StringAlignmentNear 
     
    Redraw 
    SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) + WS_EX_LAYERED 
    SetLayeredWindowAttributes Me.hWnd, &HFF00FF, 0, LWA_COLORKEY 
 
    Dim sX As Single, sY As Single 
    If x <> 0 Then 
        sX = x 
        If sX < 0 Then sX = 0 
        If (sX + fW) * tX > Screen.Width Then sX = sX - fW 
        sX = sX * tX 
         
        Me.Left = sX 
    End If 
    If y <> 0 Then 
        sY = y 
        If sY < 0 Then sY = 0 
        If (sY + fH) * tY > Screen.Height Then sY = sY - OutSkip - fH 
        sY = sY * tY 
         
        Me.Top = sY 
    End If 
    MenuShown = True 
     
    Me.Show 
End Sub 
 
Private Sub Form_Load() 
    mMenuProc.SubClass hWnd 
     
    GdipCreateFromHDC hDC, graphics 
     
    SetWindowPos Me.hWnd, -1, 0, 0, 0, 0, 3 
End Sub 
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 
    SetOverIndex -1 
End Sub 
 
Private Sub Form_Unload(Cancel As Integer) 
    On Error Resume Next 
     
    mMenuProc.UnSubClass hWnd 
     
    Dim I As Long 
    If lblC.UBound > 0 Then 
        For I = 1 To lblC.UBound 
            Unload lblC(I) 
        Next 
    End If 
    MenuCount = 0 
    Erase Menu 
     
    GdipDeleteGraphics graphics 
     
    GdipDeleteStringFormat strFormat 
    GdipDeleteFontFamily fontFamily 
    GdipDeleteFont cFont 
    GdipDeleteBrush bT_n 
    GdipDeleteBrush bT_o 
    GdipDisposeImage bBg 
    GdipDisposeImage bHl 
    GdipDisposeImage bSp 
     
    MenuShown = False 
End Sub 
 
Private Sub lblC_Click(Index As Integer) 
    CallBack.MenuItemClicked MenuID, Menu(Index).ID 
     
    Unload Me 
End Sub 
 
Private Sub lblC_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) 
    timMouse.Enabled = True 
     
    SetOverIndex Index 
End Sub 
 
Private Sub Redraw() 
    Dim I As Integer 
     
    GdipGraphicsClear graphics, &HFFFF00FF 
    GdipDrawImageRectI graphics, bBg, 0, 0, fW, fH 
    If OverIndex >= 0 Then GdipDrawImageRectI graphics, bHl, 3, lblC(OverIndex).Top, fW - 6, 22 
     
    For I = 0 To MenuCount - 1 
        With Menu(I) 
            If .ItemType = NormalItem Then 
                If OverIndex <> I Then 
                    GdipDrawString graphics, StrPtr(.Caption), .CaptionLength, cFont, .RECT, strFormat, bT_n 
                Else 
                    GdipDrawString graphics, StrPtr(.Caption), .CaptionLength, cFont, .RECT, strFormat, bT_o 
                End If 
                 
                If .Icon.Icon <> 0 Then 
                    GdipDrawImageRectI graphics, .Icon.Icon, 16 - .Icon.Width / 2, .RECT.Top + 7 - .Icon.Height / 2, .Icon.Width, .Icon.Height 
                End If 
            Else 
                GdipDrawImageRectI graphics, bSp, 29, .RECT.Top, fW - 32, 4 
            End If 
        End With 
    Next 
     
    Me.Refresh 
End Sub 
 
Private Sub timMouse_Timer() 
    Dim rt As RECT, Point As POINTAPI 
 
    GetCursorPos Point 
    GetWindowRect Me.hWnd, rt 
 
    If Point.x < rt.Left Or Point.x > rt.Right Or Point.y < rt.Top Or Point.y > rt.Bottom Then 
        timMouse.Enabled = False 
         
        OverIndex = -1 
        Redraw 
    End If 
End Sub 
 
Public Sub UnloadMenu() 
    Unload Me 
End Sub