Dec 182017
 
Visual Basic menu routines, full source code.
File VBMENU.ZIP from The Programmer’s Corner in
Category BASIC Language
Visual Basic menu routines, full source code.
File Name File Size Zip Size Zip Type
MENUBMPS.EXE 29828 6549 deflated
MENUBMPS.FRM 27329 5799 deflated
MENUBMPS.MAK 46 41 deflated
MENUBMPS.TXT 5201 1630 deflated
TPCREAD.ME 199 165 deflated

Download File VBMENU.ZIP Here

Contents of the MENUBMPS.TXT file


DefInt A-Z

'Window API Function Declarations
'
Declare Function GetMenu% Lib "user" (ByVal hwnd%)
Declare Function GetSubMenu% Lib "user" (ByVal hMenu%, ByVal nPos%)
Declare Function GetMenuItemID% Lib "user" (ByVal hMenu%, ByVal nPos%)
Declare Function ModifyMenu% Lib "user" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%, ByVal wIDNewItem%, ByVal lpNewItem&)
Declare Function SetMenuItemBitmaps% Lib "user" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%, ByVal hBitmapUnchecked%, ByVal hBitmapChecked%)
Declare Function TrackPopupMenu Lib "user" (ByVal hMenu, ByVal r1, ByVal X, ByVal Y, ByVal r2, ByVal hwnd, ByVal r3&)
Declare Function GetSystemMenu Lib "user" (ByVal hwnd%, ByVal revert%) As Integer
Const MF_BITMAP = &H4

Const CLR_MENUBAR = &H80000004

Const TRUE = -1, FALSE = 0

Dim TextItems$(4), LastSelection%, CurrentText%, hMenu%

Sub Form_Load ()

'* Obtain handle to the Forms top level menu

hMenu% = GetMenu(hwnd)

Static_Bitmaps_To_Menus

'* Initial String with text displayed when menus are selected.
'* (Just so something happens when a menu is selected.)

TextItems$(0) = "Writing Tools"
TextItems$(1) = "Fonts"
TextItems$(2) = "Books/Notes"
TextItems$(3) = "Printers"
TextItems$(4) = "Computers"

'* Set "Dynamic" menus submenus initial Menu text values
'* to Fontname + Fontsize of each menu item

For I% = 0 To 4
MSubMenu(I%).Caption = picture3(I%).FontName + Str$(picture3(I%).FontSize) + " Pnt"
Next I%

End Sub

Sub SubMenu_Click (Index As Integer)

Static LastSelection%

'* Set text to that of selected menu item and
'* display the new text

CurrentText% = Index
Form_Paint

'* Uncheck last selected item and check seledted item

SubMenu(LastSelection%).Checked = FALSE 'Check selected menu
SubMenu(Index).Checked = TRUE 'UnCheck last selected menu

LastSelection% = Index 'Save current selection

End Sub

Sub MSubMenu_Click (Index As Integer)

Static LastSelection%

'* Reset forms FontSize to selected fontsize
'* and redisplay current text

FontSize = picture3(Index).FontSize
Form_Paint

'* Uncheck last selected item and check selected item

MSubMenu(LastSelection%).Checked = FALSE
MSubMenu(Index).Checked = TRUE

LastSelection% = Index

End Sub

Sub Create_Dynamic_Menu_Bitmaps ()

For I% = 0 To 4

'* Set the width and height of the Picture controls
'* based on their corresponding Menu items caption,
'* and the Picture controls Font and FontSize.
'* DoEvents() is neccessary to make new dimension
'* values to take affect prior to exiting this Sub.

picture3(I%).Width = picture3(I%).TextWidth(MSubMenu(I%).Caption)
picture3(I%).Height = picture3(I%).TextHeight(MSubMenu(I%).Caption)
X% = DoEvents()

'* Set Backcolor of Picture control to that of the
'* current system Menu Bar color, so Dynamic bitmaps
'* will appear as normal menu items when menu bar
'* color is changed via the control panel

picture3(I%).BackColor = CLR_MENUBAR

'* Print Text onto Picture control. This text will
'* become the bitmap.

picture3(I%).Print MSubMenu(I%).Caption

Next I%

'* Obtain handle Second submenu

hSubMenu% = GetSubMenu(hMenu%, 1)

'* - Set picture controls backgroup picture (Bitmap) to its Image.
'* Can't use the Image bitmap directly for some reason.
'* - Get ID of sub menu
'* - Replace menu text with bitmap from corresponding picture control
'* - Replace bitmap for menu check mark with custom check mark bitmap

For I% = 0 To 4
picture3(I%).Picture = picture3(I%).Image
menuId% = GetMenuItemID(hSubMenu%, I%)
X% = ModifyMenu(hMenu%, menuId%, MF_BITMAP, menuId%, CLng(picture3(I%).Picture))
X% = SetMenuItemBitmaps(hMenu%, menuId%, 0, 0, CLng(picture2.Picture))
Next I%

End Sub

Sub Form_Paint ()
Cls
Print TextItems$(CurrentText%)
End Sub

Sub CreateDynamic_Click ()
CreateDynamic.enabled = FALSE
Create_Dynamic_Menu_Bitmaps
End Sub

Sub Static_Bitmaps_To_Menus ()

'* Obtain handle to first submenu

hSubMenu% = GetSubMenu(hMenu%, 0)

'* - Get ID of each sub menu
'* - Replace menu text with bitmap from corresponding picture control
'* - Replace bitmap for menu check mark with custom check mark bitmap

For I% = 0 To 4
menuId% = GetMenuItemID(hSubMenu%, I%)
X% = ModifyMenu(hMenu%, menuId%, MF_BITMAP, menuId%, CLng(picture1(I%).Picture))
X% = SetMenuItemBitmaps(hMenu%, menuId%, 0, 0, CLng(picture2.Picture))
Next I%

SubMenu(1).enabled = 0
hMenu% = GetSystemMenu(hwnd, 0)
menuId% = &HF120
X% = ModifyMenu(hMenu%, menuId%, MF_BITMAP, menuId%, CLng(picture3(0).Picture))

End Sub

Sub Form_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)

ScaleMode = 3
InPixels = ScaleWidth
ScaleMode = 1
IX = (X + Left) \ (ScaleWidth \ InPixels)
IY = (Y + (Top + (Height - ScaleHeight - (Width - ScaleWidth)))) \ (ScaleWidth \ InPixels)
R = TrackPopupMenu(GetSubMenu(hMenu%, Button - 1), 0, IX, IY, 0, hwnd, 0)

End Sub



 December 18, 2017  Add comments

Leave a Reply