mdlmenu.bas

mp3播放器软件

Attribute VB_Name = "mdlMenu"
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2007/09/23
'描    述：局域网电影共享平台(湖南农大吧专版)
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'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
'==================================================================