www.pudn.com > QQ2009.rar > cDropDown.ctl, change:2009-10-03,size:4961b


VERSION 5.00 
Begin VB.UserControl cDropDown  
   AutoRedraw      =   -1  'True 
   BackColor       =   &H00FFF4E4& 
   ClientHeight    =   3600 
   ClientLeft      =   0 
   ClientTop       =   0 
   ClientWidth     =   4800 
   ScaleHeight     =   240 
   ScaleMode       =   3  'Pixel 
   ScaleWidth      =   320 
End 
Attribute VB_Name = "cDropDown" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = True 
Attribute VB_PredeclaredId = False 
Attribute VB_Exposed = False 
Option Explicit 
 
Dim fMenu As New frmMenu 
 
Dim graphics As Long 
Dim pathOuter As Long, pathInner As Long, bOver As Long, bDown As Long, pOuter As Long, pInner As Long 
 
Dim Icons() As IconStruct, lstID As Long 
Dim Menu() As MenuItem, MenuCount As Long 
Public ActiveIndex As Long 
 
Dim mouseOver As Boolean, mouseDown As Boolean 
 
Private Sub UserControl_Click() 
    Dim rc As Rect, i As Long 
     
    GetWindowRect hWnd, rc 
     
    Load fMenu 
    Set fMenu.CallBack = Me 
    With fMenu 
        .InitMenu 0 
        For i = 0 To MenuCount - 1 
            .AddMenu Menu(i).ID, Menu(i).ItemType, Menu(i).Caption, Menu(i).Icon.Icon 
        Next 
        .ShowMenu rc.Left, rc.Bottom, rc.Bottom - rc.Top 
    End With 
End Sub 
 
Public Sub MenuItemClicked(ByVal MenuID As Long, ByVal ItemIndex As Long) 
    ActiveIndex = ItemIndex 
     
    ReDraw 
End Sub 
 
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    mouseDown = True 
     
    ReDraw 
End Sub 
 
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    Dim oldFlag As Boolean 
    oldFlag = mouseOver 
     
    If X < 0 Or Y < 0 Or X > UserControl.ScaleWidth Or Y > UserControl.ScaleHeight Then 
        mouseOver = False 
 
        ReleaseCapture 
    Else 
        mouseOver = True 
         
        SetCapture UserControl.hWnd 
    End If 
     
    If oldFlag <> mouseOver Then ReDraw 
End Sub 
 
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
    mouseDown = False 
     
    ReDraw 
End Sub 
 
Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 
    If Ambient.UserMode Then 
        Dim p1 As POINTF, p2 As POINTF 
        p1.X = 0: p1.Y = 2 
        p2.X = 0: p2.Y = 20 
         
        CreateRoundRectPath 0, 0, 32, 22, 4, pathOuter 
        CreateRoundRectPath 1, 1, 30, 20, 2, pathInner 
        GdipCreateLineBrush p1, p2, &HFF6BE1FD, &HFF0F98DF, WrapModeTileFlipY, bOver 
        GdipCreateLineBrush p1, p2, &HFF0F98DF, &HFF6BE1FD, WrapModeTileFlipY, bDown 
        GdipCreatePen1 &HFF2CA2E8, 1, UnitPixel, pOuter 
        GdipCreatePen2 &HA0A5EEFE, 1, UnitPixel, pInner 
         
        GdipCreateFromHDC UserControl.hDC, graphics 
         
        ReDraw 
    End If 
End Sub 
 
Private Sub UserControl_Resize() 
    UserControl.Height = 22 * Screen.TwipsPerPixelY 
    UserControl.Width = 32 * Screen.TwipsPerPixelX 
End Sub 
 
Public Sub UnInit() 
    Dim i As Long 
    For i = 0 To lstID - 1 
        GdipDisposeImage Icons(i).Icon 
    Next 
     
    GdipDeletePen pOuter 
    GdipDeletePen pInner 
    GdipDeletePath pathOuter 
    GdipDeletePath pathInner 
    GdipDeleteBrush bOver 
    GdipDeleteBrush bDown 
    GdipDeleteGraphics graphics 
End Sub 
 
Public Sub ReDraw() 
    On Error GoTo ErrHandle 
     
    If GdipGraphicsClear(graphics, &HFFE4F4FF) <> Ok Then GoTo ErrHandle 
     
    If mouseOver And Not mouseDown Then 
        GdipDrawPath graphics, pOuter, pathOuter 
        GdipFillRectangleI graphics, bOver, 2, 2, 30, 20 
        GdipDrawPath graphics, pInner, pathInner 
    ElseIf mouseDown Then 
        GdipDrawPath graphics, pOuter, pathOuter 
        GdipFillRectangleI graphics, bDown, 2, 2, 30, 20 
        GdipDrawPath graphics, pInner, pathInner 
    End If 
     
    GdipDrawImageRectI graphics, Icons(ActiveIndex).Icon, 4, 11 - Icons(ActiveIndex).Height / 2, Icons(ActiveIndex).Width, Icons(ActiveIndex).Height 
     
    Refresh 
ErrHandle: 
End Sub 
 
Public Sub AddItem(ItemType As MenuItemType, Optional ItemCaption As String, Optional IconPath As String) 
    ReDim Preserve Menu(MenuCount) 
    ReDim Preserve Icons(lstID) 
     
    With Menu(MenuCount) 
        .ItemType = ItemType 
         
        If ItemType = NormalItem Then 
            .ID = lstID 
            .Caption = ItemCaption 
            If Len(IconPath) > 0 Then 
                GdipLoadImageFromFile StrPtr(IconPath), Icons(lstID).Icon 
                GdipGetImageWidth Icons(lstID).Icon, Icons(lstID).Width 
                GdipGetImageHeight Icons(lstID).Icon, Icons(lstID).Height 
                .Icon.Icon = Icons(lstID).Icon 
            End If 
             
            lstID = lstID + 1 
        Else 
            .ID = -1 
        End If 
    End With 
     
    MenuCount = MenuCount + 1 
End Sub 
 
Private Sub UserControl_Terminate() 
    Erase Menu 
    Erase Icons 
End Sub