Mastering Visual Basic 5/MasteringVisualBasic5.iso/ch_code/ch12/menumod/menumod.frm

Visual Basic Form | 1997-02-20 | 6.3 KB | 174 lines

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Menu with Bitmap Graphics"
   ClientHeight    =   2070
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   2070
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox Picture1
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   735
      Left            =   480
      ScaleHeight     =   735
      ScaleWidth      =   975
      TabIndex        =   0
      Top             =   1080
      Visible         =   0   'False
      Width           =   975
   End
   Begin VB.Label Label1
      Caption         =   "You can switch the menu items between text and graphics by clicking on Bitmaps->Display Graphics."
      Height          =   615
      Left            =   240
      TabIndex        =   1
      Top             =   360
      Width           =   4215
   End
   Begin VB.Menu Bitmaps
      Caption         =   "Bitmaps"
      Begin VB.Menu MyMenu
         Caption         =   "Happy Face"
         Index           =   0
      End
      Begin VB.Menu MyMenu
         Caption         =   "Donut"
         Index           =   1
      End
      Begin VB.Menu MyMenu
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu MyMenu
         Caption         =   "Display Graphics"
         Checked         =   -1  'True
         Index           =   3
      End
      Begin VB.Menu Exit
         Caption         =   "Exit"
         Index           =   1
      End
   End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, _
    ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, _
    ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _
    (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _
    ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Private 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
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Const MF_STRING = &H0&
Const SRCCOPY = &HCC0020
Const MF_BYPOSITION = &H400&
Const MF_BITMAP = &H4&
Private Sub Exit_Click(Index As Integer)
    Unload Me
End Sub
Private Sub Form_Load()
    Call DisplayBitmapMenu
End Sub
Private Sub MyMenu_Click(Index As Integer)
    'Display text
    If MyMenu(3).Checked Then
        MyMenu(3).Checked = False
        Call DisplayTextMenu
    Else
        MyMenu(3).Checked = True
        Call DisplayBitmapMenu
    End If
End Sub
Private Sub DisplayTextMenu()
    Dim hMenuID As Long
    Dim menuID As Long
    Dim menuPos As Integer
    Dim retValue As Long
   'Get handle to menu
    hMenuID = GetSubMenu(GetMenu(Me.hwnd), 0)
    menuPos = 0
    menuID = GetMenuItemID(hMenuID, menuPos)
    retValue = ModifyMenu(hMenuID, menuPos, MF_BYPOSITION Or MF_STRING, _
                            menuID, "Happy Face")
    menuPos = 1
    menuID = GetMenuItemID(hMenuID, menuPos)
    retValue = ModifyMenu(hMenuID, menuPos, MF_BYPOSITION Or MF_STRING, _
                            menuID, "Donut")
End Sub
Private Sub DisplayBitmapMenu()
    Dim Width As Integer
    Dim Height As Integer
    Dim hTmpDC As Long
    Dim hMenuID As Long
    Dim hBitmap As Long
    Dim retValue As Long
    Dim tmpID As Long
    Dim fileName As String
    Dim menuPos As Integer
    Dim menuID As Long
    'Set menu position and file name
    menuPos = 0
    fileName = App.Path & "\face03.ico"
    Picture1.Picture = LoadPicture(fileName)
    Width = Picture1.Width / Screen.TwipsPerPixelX
    Height = Picture1.Height / Screen.TwipsPerPixelY
    'Get handle to menu
    hMenuID = GetSubMenu(GetMenu(Me.hwnd), menuPos)
    'Create device context to store bitmap
    hTmpDC = CreateCompatibleDC(Picture1.hdc)

    'Create the bitmap for the picture
    hBitmap = CreateCompatibleBitmap(Picture1.hdc, Width, Height)

    'Select bitmap into temporary dc
    tmpID = SelectObject(hTmpDC, hBitmap)
    'Copy contents from picture control to DC
    retValue = BitBlt(hTmpDC, 0, 0, Width, Height, Picture1.hdc, _
                        0, 0, SRCCOPY)

    'Deselect bitmap
    tmpID = SelectObject(hTmpDC, tmpID)
    'Modify the menu
    menuID = GetMenuItemID(hMenuID, menuPos)
    retValue = ModifyMenu(hMenuID, menuPos, MF_BYPOSITION Or MF_BITMAP, _
                            menuID, hBitmap)
    'Second menu item
    menuPos = 1
    fileName = App.Path & "\donuts.ico"
    Picture1.Picture = LoadPicture(fileName)
     'Create the bitmap for the picture
    hBitmap = CreateCompatibleBitmap(Picture1.hdc, Width, Height)

    'Select bitmap into temporary dc
    tmpID = SelectObject(hTmpDC, hBitmap)
    retValue = BitBlt(hTmpDC, 0, 0, Width, Height, Picture1.hdc, _
                        0, 0, SRCCOPY)

    tmpID = SelectObject(hTmpDC, tmpID)
    menuID = GetMenuItemID(hMenuID, menuPos)
    retValue = ModifyMenu(hMenuID, menuPos, MF_BYPOSITION Or MF_BITMAP, _
                            menuID, hBitmap)

    'Clean up
    retValue = DeleteDC(hTmpDC)
End Sub