'//該源碼下載自www.aspx1.com(ａｓｐｘ１．ｃｏｍ)

Attribute VB_Name = "mdlMenu"
'****************************************************************************
'人人為我，我為人人
'枕善居收藏整理
'發布日期：2007/09/23
'描    述：局域網電影共享平臺(湖南農大吧專版)
'網    站：http://www.Mndsoft.com/  (VB6源碼博客)
'網    站：http://www.VbDnet.com/   (VB.NET源碼博客,主要基于.NET2005)
'e-mail  ：Mndsoft@163.com
'e-mail  ：Mndsoft@126.com
'OICQ    ：88382850
'          如果您有新的好的代碼別忘記給枕善居哦!
'****************************************************************************

Option Explicit

 

Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Type POINTS
    X  As Integer
    Y  As Integer
End Type

Public Const MF_BITMAP = &H4
Public Const MF_BYPOSITION = &H400
Public Const SRCCOPY = &HCC0020

Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function ModifyMenuBynum Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Dim FloatBitmap&


'==================================================================
' Create a custom bitmap checkmark and return a
' handle to that bitmap.
Function GetNewCheck&(picBox As PictureBox)
    Dim bm As BITMAP
    Dim pt As POINTS
    Dim newbm&
    Dim tdc&, oldbm&
    Dim di&
    
    '設置菜單復選框的大小。
    pt.X = 16: pt.Y = 16
    
    di& = GetObjectAPI(picBox.Image, Len(bm), bm)
    
    bm.bmBits = 0
    bm.bmWidth = pt.X
    bm.bmHeight = pt.Y
    newbm& = CreateBitmapIndirect(bm)
    
    tdc& = CreateCompatibleDC(picBox.hdc)
    oldbm& = SelectObject(tdc, newbm&)
    
    di& = BitBlt(tdc&, 0, 0, pt.X, pt.Y, picBox.hdc, 0, 0, SRCCOPY)
    oldbm& = SelectObject(tdc&, oldbm&)
    di& = DeleteDC(tdc&)
    
    GetNewCheck = newbm&
End Function
'==================================================================


'==================================================================
'將菜單的復選框設置為位圖。
Sub MnuChkBitmap(Frm As Form, pic As PictureBox, Mnu&, SubMnu&)
    Dim topmenuhnd&
    Dim floatmenu&
    Dim NewCheck&
    Dim oldbkcolor&
    Dim di&

    'Get the new checkmark bitmap
    NewCheck& = GetNewCheck(pic)
    
    'Get a handle to the top level menu
    topmenuhnd& = GetMenu(Frm.hwnd)
    
    'Get a handle to the first popup
    floatmenu& = GetSubMenu(topmenuhnd&, Mnu&)
    
    'And set the new check bitmap for the first (entry1) menu item
    di& = SetMenuItemBitmaps(floatmenu&, SubMnu&, MF_BYPOSITION, 0, NewCheck&)
    
End Sub
'==================================================================


'==================================================================
'This function makes a copy of the Image property
'of the specified image control and returns a handle to that bitmap
Function CopyPictureImage&(pic As PictureBox)
    Dim bm As BITMAP
    Dim newbm&
    Dim tdc&, oldbm&
    Dim di&

    ' First get the information about the image bitmap
    di = GetObjectAPI(pic.Image, Len(bm), bm)
    bm.bmBits = 0
    ' Create a new bitmap with the same structure and size
    ' of the image bitmap
    newbm& = CreateBitmapIndirect(bm)

    ' Create a temporary memory device context to use
    tdc& = CreateCompatibleDC(pic.hdc)
    ' Select in the newly created bitmap
    oldbm& = SelectObject(tdc&, newbm&)

    ' Now copy the bitmap from the persistant bitmap in
    ' picture 2 (note that picture2 has AutoRedraw set TRUE
    di& = BitBlt(tdc, 0, 0, bm.bmWidth, bm.bmHeight, pic.hdc, 0, 0, SRCCOPY)
    ' Select out the bitmap and delete the memory DC
    oldbm& = SelectObject(tdc&, oldbm&)
    di& = DeleteDC(tdc&)

    ' And return the new bitmap
    CopyPictureImage& = newbm&
End Function
'==================================================================


'==================================================================
'將一條菜單設置成為位圖。
Sub MnuChgBitmap(Frm As Form, pic As PictureBox, Mnu&, SubMnu&)
    Dim topmenuhnd&
    Dim floatmenu&
    Dim menuid&
    Dim di&
    
    ' Get a handle to the top level menu
    topmenuhnd& = GetMenu(Frm.hwnd)
    
    ' And get a handle to the Floating popup menu.
    floatmenu& = GetSubMenu(topmenuhnd&, Mnu&)
    
    ' Now get the ID of that entry
    menuid& = GetMenuItemID(floatmenu&, Mnu&)
    
    FloatBitmap& = CopyPictureImage(pic)
    
    ' And replace it with a bitmap.
    di& = ModifyMenuBynum(floatmenu&, Mnu&, _
                          MF_BITMAP Or MF_BYPOSITION, _
                          menuid&, FloatBitmap&)
End Sub
'==================================================================