VB Menu

Is there a way to change the font/font size of the items contained by a VB menu (the dropdown menu in the top a a form) ?

Merry Christmas...
PleinpopossumAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

TimCotteeHead of Software ServicesCommented:
I don't think that you can change the font / fontsize for only one specific application. You could use API calls to change the font used by windows for menus whilst your application is running, but this will obviously change the font / size for all applications that are currently running.
0
naskomCommented:
If you want you can use bitmap pictures like menu items.
It is not difficult
If you want tell me to past you the code as answer

E.g.

File
 < IMAGE HERE >
 < IMAGE HERE >
 ...
 ...
 ...
0
TimCotteeHead of Software ServicesCommented:
Ok I was wrong, having looked about a bit, I found some code on www.planet-source-code.com which has owner drawn stuff for menus. I took this as a basis and added some font handling and Hey Presto, you can change the font characteristics for a menu!

There is a lot of code, but it does seem to work!

Module: OMenu_h

Option Explicit

'/////////////////////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////////////////////
'////                                                                         ////
'//// OMenu_h - This module is built in conjunction with the COwnMenu class.  ////
'////           This program demonstrates a popular object registration and   ////
'////           iteration process. This module maintains a list of COwnMenu   ////
'////           objects and pumps information and commands to them as the     ////
'////           Operating System dictates.                                    ////
'////                                                                         ////
'//// ----------------------------------------------------------------------- ////
'////                                                                         ////
'//// This program was created by Kalani Thielen on 04/14/98                  ////
'//// You may use the provided code module and object module if this text     ////
'//// appears within it.                                                      ////
'////                                                                         ////
'//// NOTE: If this code is used within a commercial (for profit) application ////
'////       please send US $20.00 in a self-addressed stamped envelope to:    ////
'////               Kalani Thielen                                            ////
'////               430 Quintana Road PMB 122                                 ////
'////               Morro Bay, CA 93442                                       ////
'////                                                                         ////
'//// For more programming information visit my website,                      ////
'//// the website is: http://www.calcoast.com/kalani/                         ////
'////                                                                         ////
'/////////////////////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////////////////////

'///////////////////////////////////////////////////
'// m_omList() is a dynamic array of COwnMenu
'// objects which represent individual menu entries
'///////////////////////////////////////////////////
Private m_omList() As COwnMenu
Private m_nOMCount As Long
Private m_bListInitialized As Boolean

'//////////////////////////////////////////////////////
'/// m_lPrevProc is the address of the procedure
'/// previously associated with the subclassed window
'//////////////////////////////////////////////////////
Private m_lPrevProc As Long

'////////////////////////////////////////////////////////////////
'//// Windows API functions
'////////////////////////////////////////////////////////////////
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
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

'////////////////////////////////////////////////////////////////
'//// Windows API Constants
'////////////////////////////////////////////////////////////////
Private Const MF_OWNERDRAW = &H100&
Private Const MF_BYPOSITION = &H400&
Private Const GWL_WNDPROC = (-4)
Private Const WM_DRAWITEM = &H2B
Private Const WM_MEASUREITEM = &H2C
Private Const WM_COMMAND = &H111

'////////////////////////////////////////////////////////////////
'//// Structures used for Windows API functions
'////////////////////////////////////////////////////////////////
Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type MEASUREITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemWidth As Long
        itemHeight As Long
        itemData As Long
End Type

Public Type DRAWITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemAction As Long
        itemState As Long
        hwndItem As Long
        hdc As Long
        rcItem As RECT
        itemData As Long
End Type

'// text measurement functions/structures
Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Type SIZE
        cx As Long
        cy As Long
End Type

'/////////////////////////////////////////////////////////
'////
'//// FreeMenus - Frees the memory allocated on the heap
'////             for our COwnMenu objects
'////
'/////////////////////////////////////////////////////////
Public Sub FreeMenus()
Dim nIndex As Long
For nIndex = 0 To m_nOMCount
    Set m_omList(nIndex) = Nothing
Next nIndex

m_nOMCount = 0
ReDim m_omList(0)
End Sub


'// Thiw procedure will tell Windows how big our items are.
Private Sub MeasureItem(ByRef mnu As COwnMenu, ByRef lpMeasureInfo As MEASUREITEMSTRUCT)
Dim hDrawDC As Long
Const MENU_HEIGHT = 20 '// average menu size, change if you want larger menu items
Const IMAGE_WIDTH = 16 '// the width of the image blt'ed into the menu dc

hDrawDC = GetDC(mnu.hwndOwner)

Dim lpSize As SIZE
GetTextExtentPoint32 hDrawDC, mnu.Caption, Len(mnu.Caption), lpSize

lpMeasureInfo.itemHeight = MENU_HEIGHT
lpMeasureInfo.itemWidth = lpSize.cx + IMAGE_WIDTH

ReleaseDC mnu.hwndOwner, hDrawDC
End Sub
Public Sub MakeOwnerDraw(hMenu As Long, nIndex As Long, nID As Long)
'// Modify the menu's attributes
ModifyMenu hMenu, nIndex, MF_OWNERDRAW Or MF_BYPOSITION, nID, vbNullString
End Sub



'/////////////////////////////////////////////////////////////////
'////
'//// IconProc - Your standard WndProc (Handles window messages)
'////
'/////////////////////////////////////////////////////////////////
Public Function IconProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim nRegisteredIndex As Long '// Used to iterate through all registered menu objects

'// We must make sure that the menu object array has been initialized
'// if it has not then we have no business processing any messages
If m_bListInitialized = False Then
    IconProc = CallWindowProc(m_lPrevProc, hwnd, uMsg, wParam, lParam)
    Exit Function
End If

'// The familiar window message select case block
Select Case uMsg
    Case WM_DRAWITEM
        '// The following code will copy a structure pointed to by lParam
        '// into our lpDrawInfo structure
        Dim lpDrawInfo As DRAWITEMSTRUCT
        CopyMem lpDrawInfo, ByVal lParam, Len(lpDrawInfo)
       
        '// We must draw an owner drawn menu
        '// loop through all currently created menu objects
        '// and see if we have correctly received this message
        For nRegisteredIndex = 0 To m_nOMCount
            If (m_omList(nRegisteredIndex).MenuID) = lpDrawInfo.itemID Then
                '// We have found our registered menu
                '// Let's tell the menu object to draw itself
                m_omList(nRegisteredIndex).InitStruct lpDrawInfo.hdc, lpDrawInfo.itemAction, lpDrawInfo.itemID, lpDrawInfo.itemState, lpDrawInfo.rcItem.Left, lpDrawInfo.rcItem.Top, lpDrawInfo.rcItem.Bottom, lpDrawInfo.rcItem.Right
                m_omList(nRegisteredIndex).DrawMenu
                Exit For
            End If
        Next nRegisteredIndex
   
    Case WM_MEASUREITEM
        Dim lpMeasureInfo As MEASUREITEMSTRUCT
       
        '// Get the MEASUREITEM struct from the pointer
        CopyMem lpMeasureInfo, ByVal lParam, Len(lpMeasureInfo)
        For nRegisteredIndex = 0 To m_nOMCount
            If (m_omList(nRegisteredIndex).MenuID) = lpMeasureInfo.itemID Then
                '// We have found our registered menu
                MeasureItem m_omList(nRegisteredIndex), lpMeasureInfo
                Exit For
            End If
        Next nRegisteredIndex
        CopyMem ByVal lParam, lpMeasureInfo, Len(lpMeasureInfo)
   
    Case Else
        '// Call previous WndProc
        IconProc = CallWindowProc(m_lPrevProc, hwnd, uMsg, wParam, lParam)
End Select
End Function

Public Sub RegisterMenu(hMenu As Long, nPosition As Long, hwndOwner As Long, sMessage As String, objPicture As Object)
'// Set this menu entry up as an owner drawn menu
MakeOwnerDraw hMenu, nPosition, GetMenuItemID(hMenu, nPosition)

'// Create a new owner drawn menu object on the heap
If (m_bListInitialized = False) Then
    ReDim m_omList(0)
    Set m_omList(0) = New COwnMenu
   
    m_omList(0).InitMenu GetMenuItemID(hMenu, nPosition), sMessage, objPicture
   
    m_bListInitialized = True
Else
    m_nOMCount = m_nOMCount + 1
   
    ReDim Preserve m_omList(m_nOMCount)
    Set m_omList(m_nOMCount) = New COwnMenu
    m_omList(m_nOMCount).hwndOwner = hwndOwner
    m_omList(m_nOMCount).InitMenu GetMenuItemID(hMenu, nPosition), sMessage, objPicture
End If
End Sub


Public Sub SetSubclass(frm As Form)
'// Store value of previous WndProc function
m_lPrevProc = GetWindowLong(frm.hwnd, GWL_WNDPROC)

'// Set new WndProc
SetWindowLong frm.hwnd, GWL_WNDPROC, AddressOf IconProc
End Sub


Class Module: COwnMenu

Option Explicit

'///////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////
'////                                                                               ////
'//// COwnMenu - This object demonstrates the process of both drawing an owner      ////
'////            drawn menu and encapsulating a complex process while still         ////
'////            allowing simple code in the actual implementation of the object.   ////
'////            While this class module may be a true work of art (No, I'm not     ////
'////            really *that* arrogant) it does leave room for a great deal of     ////
'////            improvement and customization. Hopefully you will find that the    ////
'////            framework set up in this demonstration will accomodate you in your ////
'////            mission to create any style of menu (like those funky MSN ones).   ////
'////            I only ask that you give me credit for the work I have done and    ////
'////            if you create new objects to accomodate for varying menu styles    ////
'////            that you keep this text in the object as well as your own notes    ////
'////                                                                               ////
'//// ----------------------------------------------------------------------------- ////
'////                                                                               ////
'//// This program was created by Kalani Thielen on 04/14/98                        ////
'//// You may use the provided code module and object module if this text           ////
'//// appears within it.                                                            ////
'////                                                                               ////
'//// NOTE: If this code is used within a commercial (for profit) application       ////
'////       please send US $20.00 in a self-addressed stamped envelope to:          ////
'////               Kalani Thielen                                                  ////
'////               430 Quintana Road PMB 122                                       ////
'////               Morro Bay, CA 93442                                             ////
'////                                                                               ////
'//// For more programming information visit my website,                            ////
'//// the website is: http://www.calcoast.com/kalani/                               ////
'////                                                                               ////
'///////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////

'//////////////////////////////////////////////////
'////// Object Data
'//////////////////////////////////////////////////

Private m_hMenu As Long '// The menu entry's handle
Private m_hMenuID As Long '// The menu entry's ID
Private m_sMessage As String '// The menu entry's text
Private m_objPicture As Object '// The menu entry's picture object
Private m_lpDrawStruct As DRAWITEMSTRUCT '// The menu entry's current drawing information
Public hwndOwner As Long     '// the window which owns this object

'////////////////////////////////////////////////////////////////////
'//// Windows API declarations - Used for drawing graphical data
'////                            into our menu entry's device context
'////////////////////////////////////////////////////////////////////
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
'Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

'//////////////////////////////////////////////////
'///// Constants used for Windows API functions
'//////////////////////////////////////////////////
Private Const SRCCOPY = &HCC0020

Private Const PS_SOLID = 0

Private Const COLOR_MENU = 4
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14

Private Const ODS_SELECTED = &H1

Private Const NEWTRANSPARENT = 3

'///////////////////////////////////////////////////////////////////////
'//// Constants used by our object
'//// These values represent customizable aspects of this object
'//// which may be modified for compilation or customized as to provide
'//// dynamic modification of them.
'///////////////////////////////////////////////////////////////////////
Private Const DRAWWIDTH = 1
Private Const PicWidth = 20
Private Const TEXTBUFFER = 5

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 As String
End Type

Public Property Let Caption(sMessage As String)
m_sMessage = sMessage
End Property

Public Property Get Caption() As String
Caption = m_sMessage
End Property

Public Sub InitMenu(hMenuID As Long, sMessage As String, objPicture As Object)
'// Set object state
m_hMenuID = hMenuID
m_sMessage = sMessage
Set m_objPicture = objPicture
End Sub

Public Sub InitStruct(hdc As Long, nAction As Long, nID As Long, nState As Long, nLeft As Long, nTop As Long, nBottom As Long, nRight As Long)
'// VB doesn't allow us to pass user defined structures to classes
'// therefore we have to go about it in a roundabout fashion
'// this leaves *you* as the programmer with room for future improvement
m_lpDrawStruct.hdc = hdc
m_lpDrawStruct.itemAction = nAction
m_lpDrawStruct.itemID = nID
m_lpDrawStruct.itemState = nState
m_lpDrawStruct.rcItem.Left = nLeft
m_lpDrawStruct.rcItem.Top = nTop
m_lpDrawStruct.rcItem.Bottom = nBottom
m_lpDrawStruct.rcItem.Right = nRight
End Sub

Public Property Get MenuID() As Long
MenuID = m_hMenuID
End Property


'///////////////////////////////////////////////////////////////////
'///////
'/////// PrintClear - Prints text with a clear background
'///////
'///////////////////////////////////////////////////////////////////
Private Sub PrintClear(crColor As Long)
'// Set DC background mode to clear
SetBkMode m_lpDrawStruct.hdc, NEWTRANSPARENT

'// Get old type color
Dim crOldType As Long
crOldType = GetTextColor(m_lpDrawStruct.hdc)

'// Set new type color
SetTextColor m_lpDrawStruct.hdc, crColor

'// Print text
Dim lfFont As LOGFONT
lfFont.lfHeight = 0
lfFont.lfWeight = 0
lfFont.lfEscapement = 0
lfFont.lfOrientation = 0
lfFont.lfWeight = 400
lfFont.lfItalic = 1
lfFont.lfUnderline = 1
lfFont.lfStrikeOut = 1
lfFont.lfCharSet = 0
lfFont.lfPitchAndFamily = 72
lfFont.lfFaceName = "Papyrus"
Dim hFont As Long
Dim Result As Long
hFont = CreateFontIndirect(lfFont)
Result = SelectObject(m_lpDrawStruct.hdc, hFont)
TextOut m_lpDrawStruct.hdc, PicWidth + TEXTBUFFER, m_lpDrawStruct.rcItem.Top + 2, m_sMessage, Len(m_sMessage)
DeleteObject (Result)
'// Reset old color
SetTextColor m_lpDrawStruct.hdc, crOldType
End Sub

'/////////////////////////////////////////////////////////////
'////// DrawMenu - Draws this menu entry
'/////////////////////////////////////////////////////////////
Public Sub DrawMenu()
'// Create a temporary copy of our member DRAWITEMSTRUCT
Dim lpDrawInfo As DRAWITEMSTRUCT
lpDrawInfo = m_lpDrawStruct

'// Create a brushes or get colors for specific menu attributes
'// These attributes are selected by the user in the Windows Display settings dialog
'// This ensures that menu customization will affect our menus too
Dim hSelectedItem As Long, crSelected As Long
Dim hMenuColor As Long

hSelectedItem = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
crSelected = GetSysColor(COLOR_HIGHLIGHTTEXT)
hMenuColor = CreateSolidBrush(GetSysColor(COLOR_MENU))
       
'// Draw a highlight in the selection color if this element is selected
'// If this element is not selected we must clean up our previosu drawing

Dim DrawRect As RECT
DrawRect = m_lpDrawStruct.rcItem
DrawRect.Left = (PicWidth + TEXTBUFFER) - 4

If lpDrawInfo.itemState = ODS_SELECTED Then
    FillRect lpDrawInfo.hdc, DrawRect, hSelectedItem
Else
    FillRect lpDrawInfo.hdc, lpDrawInfo.rcItem, hMenuColor
End If

'// Print this menu entry's caption
PrintClear IIf(lpDrawInfo.itemState = ODS_SELECTED, crSelected, RGB(0, 0, 0))

'// Draw the bitmap for this menu entry
StretchBlt lpDrawInfo.hdc, lpDrawInfo.rcItem.Left + DRAWWIDTH, lpDrawInfo.rcItem.Top + DRAWWIDTH, PicWidth - DRAWWIDTH, (lpDrawInfo.rcItem.Bottom - lpDrawInfo.rcItem.Top) - DRAWWIDTH, m_objPicture.hdc, 0, 0, m_objPicture.ScaleWidth, m_objPicture.ScaleHeight, SRCCOPY

'// If our menu is selected we need to draw a 3D box around the picture
If lpDrawInfo.itemState = ODS_SELECTED Then Draw3D

'// Delete used GDI objects
DeleteObject hSelectedItem
DeleteObject hMenuColor
End Sub

'//////////////////////////////////////////////////////////////////////////////////
'////
'//// Draw3D - Draws a "3D" box around our picture
'////
'//////////////////////////////////////////////////////////////////////////////////
Private Sub Draw3D()
'// Create a drawing space in
Dim rctPicture As RECT
rctPicture.Top = m_lpDrawStruct.rcItem.Top
rctPicture.Left = m_lpDrawStruct.rcItem.Left
rctPicture.Right = PicWidth
rctPicture.Bottom = m_lpDrawStruct.rcItem.Bottom

'// Create pens for drawing the box border
Dim hpBlack As Long, hpWhite As Long

hpWhite = CreatePen(PS_SOLID, DRAWWIDTH, RGB(255, 255, 255)) '// White half of box
hpBlack = CreatePen(PS_SOLID, DRAWWIDTH, RGB(70, 70, 70))    '// Dark Grey half of box

'// Draw upper left corner of box
DeleteObject SelectObject(m_lpDrawStruct.hdc, hpWhite)

MoveToEx m_lpDrawStruct.hdc, rctPicture.Left + 1, (rctPicture.Bottom - 1), 0
LineTo m_lpDrawStruct.hdc, rctPicture.Left + 1, rctPicture.Top + 1
LineTo m_lpDrawStruct.hdc, (rctPicture.Right - 1), rctPicture.Top + 1

'// Draw lower right corner of box
DeleteObject SelectObject(m_lpDrawStruct.hdc, hpBlack)

LineTo m_lpDrawStruct.hdc, (rctPicture.Right - 1), rctPicture.Bottom - 1
LineTo m_lpDrawStruct.hdc, rctPicture.Left + 1, rctPicture.Bottom - 1

'// Clean up GDI objects
DeleteObject hpWhite
DeleteObject hpBlack
End Sub

Form:

VERSION 5.00
Begin VB.Form frmOwnMenu
   Caption         =   "Owner Drawn Menu Example"
   ClientHeight    =   3375
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   4185
   Icon            =   "frmOwnMenu.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   225
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   279
   StartUpPosition =   2  'CenterScreen
   Begin VB.PictureBox pctEntry4
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   540
      Left            =   0
      Picture         =   "frmOwnMenu.frx":000C
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   3
      Top             =   1920
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.PictureBox pctEntry2
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   540
      Left            =   0
      Picture         =   "frmOwnMenu.frx":08D6
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   2
      Top             =   720
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.PictureBox pctEntry3
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   540
      Left            =   0
      Picture         =   "frmOwnMenu.frx":11A0
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   1
      Top             =   1320
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.PictureBox pctEntry1
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   540
      Left            =   0
      Picture         =   "frmOwnMenu.frx":15E2
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   0
      Top             =   120
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.Label lblKFiles
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "The 'K' Files"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   -1  'True
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   195
      Left            =   3240
      MouseIcon       =   "frmOwnMenu.frx":1EAC
      MousePointer    =   99  'Custom
      TabIndex        =   6
      Top             =   3120
      Width           =   855
   End
   Begin VB.Label lblPlug
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "For programming tutorials and products visit:"
      Height          =   195
      Left            =   120
      TabIndex        =   5
      Top             =   3120
      Width           =   3090
   End
   Begin VB.Label lblKalInfo
      BackStyle       =   0  'Transparent
      Height          =   2895
      Left            =   120
      TabIndex        =   4
      Top             =   120
      Width           =   3855
   End
   Begin VB.Menu mnuOwn
      Caption         =   "Owner Drawn Menus"
      Begin VB.Menu mnuEntry1
         Caption         =   "Entry #1"
      End
      Begin VB.Menu mnuEntry2
         Caption         =   "Entry #2"
      End
      Begin VB.Menu mnuEntry3
         Caption         =   "Entry #3"
      End
      Begin VB.Menu mnuEntry4
         Caption         =   "Entry #4"
      End
   End
   Begin VB.Menu mnuReg
      Caption         =   "Regular Menus"
      Begin VB.Menu mnuReg1
         Caption         =   "Entry #1"
      End
      Begin VB.Menu mnuReg2
         Caption         =   "Entry #2"
      End
      Begin VB.Menu mnuReg3
         Caption         =   "Entry #3"
      End
      Begin VB.Menu mnuReg4
         Caption         =   "Entry #4"
      End
   End
End
Attribute VB_Name = "frmOwnMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'/////////////////////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////////////////////
'////                                                                         ////
'//// frmOwnMenu - There isn't much to say here. Luckily the majority of      ////
'////              the work is taken care of by the OMenu_h code module,      ////
'////              which serves as an object manager and message handler,     ////
'////              and COwnMenu, which processes the actual commands and      ////
'////              draws each menu item to the screen. The only real work     ////
'////              that is done in this form module is in the InitMenus       ////
'////              procedure, which registers each menu entry with OMenu_h,   ////
'////              and in Form_Load, which initiates the subclass and calls   ////
'////              the InitMenus member function of this form. It is also     ////
'////              important to note that in Form_QueryUnload a procedure     ////
'////              in OMenu_h named "FreeMenus" is called. This procedure     ////
'////              frees the memory that is dynamically allocated by          ////
'////              OMenu_h in its registration process.                       ////
'////                                                                         ////
'//// ----------------------------------------------------------------------- ////
'////                                                                         ////
'//// If you've read this far at least it means you are making some           ////
'//// attempt to learn the code provided (Good luck to you!). If you have     ////
'//// any questions or comments please email them to KalaniCA@aol.com         ////
'//// If this example has been of use to you, you may want to visit           ////
'//// my website, at http://www.calcoast.com/kalani/                          ////
'////                                                                         ////
'//// ----------------------------------------------------------------------- ////
'////                                                                         ////
'//// This program was created by Kalani Thielen on 04/14/98                  ////
'//// You may use the provided code module and object module if this text     ////
'//// appears within it.                                                      ////
'////                                                                         ////
'//// NOTE: If this code is used within a commercial (for profit) application ////
'////       please send US $20.00 in a self-addressed stamped envelope to:    ////
'////               Kalani Thielen                                            ////
'////               430 Quintana Road PMB 122                                 ////
'////               Morro Bay, CA 93442                                       ////
'////                                                                         ////
'//// For more programming information visit my website,                      ////
'//// the website is: http://www.calcoast.com/kalani/                         ////
'////                                                                         ////
'/////////////////////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////////////////////

'// Function used to go to my web site
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_MAXIMIZE = 3

'/////////////////////////////////////////////////////////
'////
'//// InitMenus - Initializes our owner drawn menus
'////             this procedure simply registers each
'////             menu item with an appropriate
'////             COwnMenu object
'////
'/////////////////////////////////////////////////////////
Private Sub InitMenus()
'// Get top level menu handle
Dim hMainMenu As Long, hSubMenu As Long
hMainMenu = GetMenu(Me.hwnd)
hSubMenu = GetSubMenu(hMainMenu, 0)

'// Register each of our menus
RegisterMenu hSubMenu, 0, Me.hwnd, "Owner Drawn Entry #1", pctEntry1
RegisterMenu hSubMenu, 1, Me.hwnd, "Owner Drawn Entry #2", pctEntry2
RegisterMenu hSubMenu, 2, Me.hwnd, "Owner Drawn Entry #3", pctEntry3
RegisterMenu hSubMenu, 3, Me.hwnd, "Owner Drawn Entry #4", pctEntry4
End Sub
Private Sub ShowInfo()
Dim sMsg As String

sMsg = "Owner Drawn Menu Example by Kalani Thielen" & vbCrLf & vbCrLf
sMsg = sMsg & "This program demonstrates the process of subclassing your window"
sMsg = sMsg & " in order to catch commands which are passed by the Windows OS"
sMsg = sMsg & " to the windows which have created owner drawn menus." & vbCrLf & vbCrLf
sMsg = sMsg & "The COwnMenu object encapsulates the process of drawing each menu"
sMsg = sMsg & " entry and the OMenu_h code module manages a list of COwnMenu"
sMsg = sMsg & " objects which represent each menu entry that has been registered"
sMsg = sMsg & " as an owner drawn menu."

lblKalInfo.Caption = sMsg
End Sub

Private Sub Form_Load()
'// Initialize our menu objects
InitMenus

'// Set a subclass on this window so that we can process
'// requests to draw our owner drawn menus
SetSubclass Me

'// Show information about this program
ShowInfo
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'// Free the memory allocated by creating our owner drawn menus
FreeMenus
End Sub



Private Sub lblKFiles_Click()
'// Log on to the K Files web page at "http://members.aol.com/KalaniCOM"
ShellExecute 0, "open", "http://www.calcoast.com/kalani/", vbNullString, vbNullString, SW_MAXIMIZE
End Sub


Private Sub lblKFiles_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
lblKFiles.ForeColor = RGB(255, 0, 0)
End Sub


Private Sub lblKFiles_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
lblKFiles.ForeColor = RGB(0, 0, 255)
End Sub


0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

PleinpopossumAuthor Commented:
Thanks a lot. I'm really impressed by this sample. I'll need at least a week to understand it (regarding to my state after christmas parties :-))))...

Well happy new year... Xavier
0
BotchCommented:
Hi timcottee and nascom
I too want to make the font on a menu bigger.  I tried to use your code but can't seem to get it to work.  If I did something silly in applying it which I did I'm sure excuse my ignorance.

I'm using vb6 and created a standard module called OMenu_h and put all the code up to the line

"Class Module: COwnMenu

into this module


Then created a class module called COwmClass and put all code from after the class module:cownmenu line to the

end
end
end
lines before the 5 attribute lines.


I don't know where to put these as they seem to bring up an error no matter where I put them.


Then I put the rest of the code in a form called frmownmenu where I want the menu to be.  


I am wondering where to put the code given and do I need to set references for the project.  Help would be gratefully appreciated.

regards Botch

0
TimCotteeHead of Software ServicesCommented:
The section starting

Form:

VERSION 5.00
Begin VB.Form frmOwnMenu

To the end should be copied in its entirety and pasted into notepad, then save this notepad document as a vb form (frmOwnMenu.frm) then add this form to your project.
0
BotchCommented:
Hi Tim Cotee
Thanks for the reply.  Did what you said but have problems

all lines with the bigin vb.form are in read as if they are not recognised as is all picture=... lines.  

When I run the projest the error "Invalid outside procedure" appears

If I put in a dot after the vb command the only option close to form is Forms.  Am I missing a reference or did I do it wrong again.


regards
Botch

ps.  hte attribute lines seemed to have disappears themselves when I saved the notepad as a form.
0
TimCotteeHead of Software ServicesCommented:
You shouldn't see the Begin.VB section either as this is not actually VB Code but the definition of the form itself. This should only be visible when viewing a .frm file in notepad not when viewing it in the VB IDE.
0
BotchCommented:
Hi timcottee
Sorry for keep getting back to you but I can't seem to inport that file as a form.

I copy the text as you said into notepad.  Clicked on save.  Typed in frmOwnMenu.frm into the name box.  The file type is at Text files.  The only other option is all files.  I go to my project.  I try to add existing form.  I specify the location where I see the frmOwnmenu form with its form icon and all.  Its properties state it is a form too.  I select it but when it is imported it is displayed as a module in the form layout window!!!.  I must be doing something stupid.

regards
Botch.
0
TimCotteeHead of Software ServicesCommented:
When you save in notepad, if it shows Text files, notepad automatically appends .txt to the end of the filename you give so frmOwnMenu.frm becomes frmOwnMenu.frm.txt which is why VB then interprets it as a module not a form file. If you choose all files then notepad doesn't add anything to the filename you choose so vb should then recognise it properly. Alternatively rename the file without the .txt second extension.
0
BotchCommented:
Hi Timcottee
I know I probably geeting on your nerves but I would like to solve this problem
I did as you said but it still keeps showing the form as as module.  I go about it like so.  I copy

Form:
....
...

etc

in its entireity to a notepad screen.  I go to file/saveas.
I type in frmOwnMenu.frm in the name field and select all files in the type field.

I open my project.  Click on add form.  I see the frmownmenu file.  It has the form icon and the properties state it is a vb form file.  No reference to text type at all.  Yet when I inport it it is as a module.  I don't think I'm doing anything wrong.  
Please help as I would like to solve this bugging problem.

regards
Botch.

ps I am going to post it as a question called "Creating a form"
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Fonts Typography

From novice to tech pro — start learning today.