浏览器

开发平台：
Visual Basic

ClsSMenu.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsSMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'---------------------------------------------------------------------------------------
' Module    : ClsSMenu
' DateTime  : 2005-??-?? ??:??
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
'8/5/2005   :修改了text的传入方式,为asci方式(非unicode)
Option Explicit
Public MeUpID As Long
Public MeID As Long
Public IconList As cImageList ' MSComctlLib.ImageList
'普通状态
Public IcoIndex As Long
'选择状态
Public IcoSelIndex As Long
'不可用状态
Public IcoDisableIndex As Long
Private MeKey As String
Private MeText As String
Private MeChk As Boolean
Private MeRadio As Boolean
Private MeEn As Boolean
Private MeView As Boolean
Private MeSelect As Boolean
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As _
    Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal _
    wFormat As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias _
    "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam _
    As NONCLIENTMETRICS, ByVal fuWinIni As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
    "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Const LF_FACESIZE As Long = 32
Private Const SPI_GETNONCLIENTMETRICS As Long = 41
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Private Type NONCLIENTMETRICS
    cbSize As Long
    iBorderWidth As Long
    iScrollWidth As Long
    iScrollHeight As Long
    iCaptionWidth As Long
    iCaptionHeight As Long
    lfCaptionFont As LOGFONT
    iSMCaptionWidth As Long
    iSMCaptionHeight As Long
    lfSMCaptionFont As LOGFONT
    iMenuWidth As Long
    iMenuHeight As Long
    lfMenuFont As LOGFONT
    lfStatusFont As LOGFONT
    lfMessageFont As LOGFONT
End Type
Public Tag As String
'菜单Key
Public Property Let Key(SetStr As String)
    MeKey = SetStr
    
End Property
Public Property Get Key() As String
    Key = MeKey
    
End Property
'菜单文字
'仅传进asci字符
Public Property Let Text(TextStr As String)
    MeText = TextStr
    
End Property
'Public Property Get Text() As String
'    Text = MeText
'
'End Property
'选中
Public Property Let Check(SetBol As Boolean)
    Dim TempMII As MENUITEMINFO
    
    MeChk = SetBol
    
    TempMII.cbSize = 44
    TempMII.fMask = MIIM_STATE
    Call GetMenuItemInfo(MeUpID, MeID, 0, TempMII)
    'Debug.Print "&H"; Hex$(TempMII.fState)
    
    TempMII.fMask = MIIM_STATE
    TempMII.fState = TempMII.fState And (Not MFS_CHECKED) _
            Or (MFS_CHECKED And SetBol)
    Call SetMenuItemInfo(MeUpID, MeID, 0, TempMII)
    'Debug.Print "&H"; Hex$(TempMII.fState)
    
End Property
Public Property Get Check() As Boolean
    Check = MeChk
    
End Property
'选中
Public Property Let Radio(SetBol As Boolean)
    Dim TempMII As MENUITEMINFO
    Dim TextByt(0 To 256) As Byte
    
    MeRadio = SetBol
    
    TempMII.cbSize = 44
    TempMII.dwTypeData = VarPtr(TextByt(0))
    TempMII.fMask = MIIM_TYPE
    Call GetMenuItemInfo(MeUpID, MeID, 0, TempMII)
    'Debug.Print "&H"; Hex$(TempMII.fType)
    
    TempMII.fMask = MIIM_TYPE
    TempMII.fType = TempMII.fType And (Not MFT_RADIOCHECK) _
            Or (MFT_RADIOCHECK And SetBol)
    Call SetMenuItemInfo(MeUpID, MeID, 0, TempMII)
    'Debug.Print "&H"; Hex$(TempMII.fType)
    
End Property
Public Property Get Radio() As Boolean
    Radio = MeRadio
    
End Property
'可用
Public Property Let Enabled(SetBol As Boolean)
    Dim TempMII As MENUITEMINFO
    
    MeEn = SetBol
    
    TempMII.cbSize = 44
    TempMII.fMask = MIIM_STATE
    Call GetMenuItemInfo(MeUpID, MeID, 0, TempMII)
    'Debug.Print "&H"; Hex$(TempMII.fState)
    
    TempMII.fMask = MIIM_STATE
    TempMII.fState = TempMII.fState And (Not (MFS_GRAYED Or MF_DISABLED)) _
            Or ((MFS_GRAYED Or MF_DISABLED) And (SetBol = False))
    Call SetMenuItemInfo(MeUpID, MeID, 0, TempMII)
    'Debug.Print "&H"; Hex$(TempMII.fState)
    
End Property
Public Property Get Enabled() As Boolean
    Enabled = MeEn
    
End Property
'可见
Public Property Let Visible(SetBol As Boolean)
    MeView = SetBol
    
End Property
Public Property Get Visible() As Boolean
    Visible = MeView
    
End Property
'选择时
Public Property Get MenuSelect() As Boolean
    MenuSelect = MeSelect
    
End Property
Private Sub Class_Initialize()
    MeEn = True
    MeView = True
End Sub
Private Sub Class_Terminate()
    '
End Sub
'设置大小
Public Sub SetSize(ByVal lParam As Long)
    Dim hDrawDC As Long
    Dim MeMIS As MEASUREITEMSTRUCT
    Dim lpSize As Size
    
    Dim nm As NONCLIENTMETRICS
    Dim oldfont As Long, nFont As Long
        
    CopyMemory MeMIS, ByVal lParam, Len(MeMIS) '取值
    
    '获得系统默认的菜单字体
    nm.cbSize = Len(nm)
    Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, nm.cbSize, nm, 0)
    nFont = CreateFontIndirect(nm.lfMenuFont)
    
    
    'hDrawDC = GetDC(gHW) '(frmDrawMenu.hwnd)   '取得hDC
    hDrawDC = GetDC(0)
    
    oldfont = SelectObject(hDrawDC, nFont)
    
    GetTextExtentPoint32 hDrawDC, StrPtr(MeText), LenB(MeText), lpSize   '取得文字大小
    
    'lpSize.cx = trc.Right - trc.Left
    MeMIS.itemWidth = 19 + lpSize.cx + 12 + 8 - 12
    '              图标宽度 文字宽度    右箭头 默认增量
    If nm.iMenuHeight < 19 Then
        MeMIS.itemHeight = 19 '图标高度
    Else
        MeMIS.itemHeight = nm.iMenuHeight
    End If
    
    SelectObject hDrawDC, oldfont
    
    DeleteObject nFont
    
    'Call ReleaseDC(gHW,  hDrawDC) ' (frmDrawMenu.hwnd, hDrawDC) '释放hDC
    Call ReleaseDC(0, hDrawDC)
    
    CopyMemory ByVal lParam, MeMIS, Len(MeMIS) '赋值
    
End Sub
'绘制菜单
Public Sub MeDraw(ByVal lParam As Long)
    Dim MeDIS As DRAWITEMSTRUCT
    Dim TemphBr As Long
    Dim TempRect As RECT
    
    Dim tTextColor As Long
    
    
    Dim tDrawIconIndex As Long
    
    CopyMemory MeDIS, ByVal lParam, Len(MeDIS) '取值
    'Debug.Print "DC:" & MeDIS.hDC
    SetBkMode MeDIS.hdc, TRANSPARENT '设置背景透明
    
    '取得绘制属性
    MeSelect = MeDIS.itemState And ODS_SELECTED
    MeChk = MeDIS.itemState And ODS_CHECKED
    MeEn = ((MeDIS.itemState And (ODS_GRAYED Or ODS_DISABLED)) = False)
    
    '图标的RECT
    Dim IcoRect As RECT
    IcoRect = MeDIS.rcItem
    IcoRect.Right = IcoRect.Left + 19
    
    '文字的RECT
    Dim TxtRect As RECT
    TxtRect = MeDIS.rcItem
    TxtRect.Left = TxtRect.Left + 21
    
    '重画背景
    TemphBr = CreateSolidBrush(GetSysColor(COLOR_MENU))
    FillRect MeDIS.hdc, MeDIS.rcItem, TemphBr
    Call DeleteObject(TemphBr)
    
    '绘制选择时的填充矩形
    If MeSelect Then
        TempRect = TxtRect
        TempRect.Left = TempRect.Left - 1 '  20
        TemphBr = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
        FillRect MeDIS.hdc, TempRect, TemphBr
        Call DeleteObject(TemphBr)
        
    Else
        '
    End If
    
    '绘制图标边框以及网格背景
    If MeSelect Then
        If MeChk Then
            DrawEdge MeDIS.hdc, IcoRect, BDR_SUNKENOUTER, BF_RECT
        Else
            DrawEdge MeDIS.hdc, IcoRect, BDR_RAISEDINNER, BF_RECT
        End If
    Else
        If MeChk Then
            FillWG MeDIS.hdc, _
                    IcoRect.Left, IcoRect.Top, _
                    IcoRect.Right - 1, IcoRect.Bottom - 1, _
                    0, &HFFFFFF
            DrawEdge MeDIS.hdc, IcoRect, BDR_SUNKENOUTER, BF_RECT
        Else
            '
        End If
    End If
    
    '绘制图标
    If MeEn Then
        If MeSelect Then
            tDrawIconIndex = IcoSelIndex
        Else
            tDrawIconIndex = IcoIndex
        End If
    Else
        tDrawIconIndex = IcoDisableIndex
    End If
    
'    If ImgListMapTrue(IconList, tDrawIconIndex) Then
'        IconList.ListImages(tDrawIconIndex).Draw MeDIS.hdc, _
'                (IcoRect.Left + 1) * Screen.TwipsPerPixelX, _
'                (IcoRect.Top + 1) * Screen.TwipsPerPixelY, _
'                imlTransparent
'
'    End If
    IconList.Draw MeDIS.hdc, tDrawIconIndex, IcoRect.Left + 1, IcoRect.Top + 1
    
    '绘制文字
    If MeEn Then
        If MeSelect Then
            tTextColor = GetSysColor(COLOR_HIGHLIGHTTEXT)
        Else
            tTextColor = GetSysColor(COLOR_MENUTEXT)
        End If
        Call SetTextColor(MeDIS.hdc, tTextColor)
        Call DrawText(MeDIS.hdc, StrPtr(MeText), -1, TxtRect, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER)
    Else
        If MeSelect Then
            tTextColor = GetSysColor(COLOR_GRAYTEXT)
            Call SetTextColor(MeDIS.hdc, tTextColor)
            Call DrawText(MeDIS.hdc, StrPtr(MeText), -1, TxtRect, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER)
        Else
            tTextColor = GetSysColor(COLOR_BTNHIGHLIGHT)
            Call SetTextColor(MeDIS.hdc, tTextColor)
            Call DrawText(MeDIS.hdc, StrPtr(MeText), -1, TxtRect, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER)
            
            With TxtRect
                .Left = .Left - 1
                .Right = .Right - 1
                .Top = .Top - 1
                .Bottom = .Bottom - 1
            End With
                    
            tTextColor = GetSysColor(COLOR_GRAYTEXT)
            Call SetTextColor(MeDIS.hdc, tTextColor)
            Call DrawText(MeDIS.hdc, StrPtr(MeText), -1, TxtRect, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER)
        End If
    End If
        
    
    'nCount=-1 为自动算长度
    
End Sub
''确定ImageList中有没有Index指定的图片
'Public Function ImgListMapTrue(pImgList As ImageList, index As Long) As Boolean
'    If pImgList Is Nothing Then ImgListMapTrue = False: Exit Function
'    If index < 1 Or index > pImgList.ListImages.Count Then ImgListMapTrue = False: Exit Function
'    ImgListMapTrue = True
'End Function
'绘制网格
Public Sub FillWG(hdc As Long, _
        X1 As Long, Y1 As Long, _
        X2 As Long, Y2 As Long, _
        Mode As Integer, C As Long)
    Dim i As Integer, j As Integer
    Dim I1 As Integer, J1 As Integer
    
    If Mode < 0 Then '25%
        For i = Y1 To Y2 Step 2
            For j = X1 To X2 Step 4
                For I1 = 0 To 1
                    For J1 = 0 To 3
                        If i + I1 <= Y2 And j + J1 <= X2 Then
                            If ((I1 = 0 And J1 = 0) Or (I1 = 1 And J1 = 2)) Then
                                SetPixelV hdc, j + J1, (i + I1), C
                                
                            Else
                            End If
                        End If
                        
                    Next J1
                    
                Next I1
                
            Next j
            
        Next i
        
    ElseIf Mode = 0 Then '50%
        For i = Y1 To Y2
            For j = X1 To X2
                If (i - Y1 + j - X1) And 1 Then
                Else
                    SetPixelV hdc, j, i, C
                    
                End If
                
            Next j
            
        Next i
        
    Else '75%
        For i = Y1 To Y2 Step 2
            For j = X1 To X2 Step 4
                For I1 = 0 To 1
                    For J1 = 0 To 3
                        If i + I1 <= Y2 And j + J1 <= X2 Then
                            If ((I1 = 1 And J1 = 1) Or (I1 = 0 And J1 = 3)) And (i + I1 <= Y2 And j + J1 <= X2) Then
                            Else
                                SetPixelV hdc, j + J1, (i + I1), C
                                
                            End If
                        End If
                        
                    Next J1
                    
                Next I1
                
            Next j
            
        Next i
        
    End If
    
End Sub

						