vbAccelerator - Contents of code file: fODMenu.frm

VERSION 5.00
Begin VB.Form fODMenu 
   Caption         =   "Popup Menu Owner Draw Style Demonstration"
   ClientHeight    =   3195
   ClientLeft      =   3855
   ClientTop       =   2460
   ClientWidth     =   5925
   Icon            =   "fODMenu.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   5925
   Begin VB.CommandButton cmdHighlight 
      Caption         =   "&Highlight"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   1260
      TabIndex        =   2
      Top             =   720
      Width           =   1035
   End
   Begin VB.PictureBox picDemo 
      BackColor       =   &H80000005&
      FillColor       =   &H80000005&
      Height          =   1275
      Left            =   60
      ScaleHeight     =   1215
      ScaleWidth      =   5715
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   1260
      Width           =   5775
   End
   Begin VB.CommandButton cmdLinePicker 
      Caption         =   "&Line Style"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   60
      TabIndex        =   0
      Top             =   720
      Width           =   1155
   End
   Begin VB.Label lblInfo 
      Caption         =   "Click either of the two buttons below to demonstrate
       menus drawn entirely within the code of this form:"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   555
      Left            =   60
      TabIndex        =   3
      Top             =   120
      Width           =   5775
   End
   Begin VB.Image imgPointNow 
      Height          =   480
      Left            =   300
      Picture         =   "fODMenu.frx":1272
      Top             =   2640
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgPoint 
      Height          =   480
      Left            =   60
      Picture         =   "fODMenu.frx":157C
      Top             =   2640
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Image imgTick 
      Height          =   480
      Left            =   480
      Picture         =   "fODMenu.frx":1886
      Top             =   2640
      Visible         =   0   'False
      Width           =   480
   End
End
Attribute VB_Name = "fODMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private m_sCurrentMenu As String

Private WithEvents c As cPopupMenu
Attribute c.VB_VarHelpID = -1

Private Sub pDrawLine(ByVal hdc As Long, ByVal lMenuIndex As Long, ByRef tR As
 RECT, ByVal lColor As Long)
Dim iLineWidth As Long
Dim iLineStyle As Long
Dim lY As Long

   iLineStyle = c.ItemData(lMenuIndex)
   iLineWidth = c.ItemKey(lMenuIndex)
   Select Case iLineStyle
   Case 1
      ' single line:
      lY = tR.tOp + (tR.Bottom - tR.tOp) \ 2 - 2
      pDrawOneLine hdc, tR.left, tR.Right, lY, (iLineWidth \ 100), , lColor
   Case 2
      ' two thin lines:
      lY = tR.tOp + (tR.Bottom - tR.tOp) \ 2 - 2
      lY = lY - 1
      pDrawOneLine hdc, tR.left, tR.Right, lY, 1, , lColor
      lY = lY + 1
      pDrawOneLine hdc, tR.left, tR.Right, lY, 1, , lColor
   Case 3
      ' thin then thick:
      lY = tR.tOp + (tR.Bottom - tR.tOp) \ 2 - 2
      lY = lY - 2
      pDrawOneLine hdc, tR.left, tR.Right, lY, 1, , lColor
      lY = lY + 3
      pDrawOneLine hdc, tR.left, tR.Right, lY, 2, , lColor
   Case 4
      ' thick then thin:
      lY = tR.tOp + (tR.Bottom - tR.tOp) \ 2 - 2
      lY = lY - 2
      pDrawOneLine hdc, tR.left, tR.Right, lY, 2, , lColor
      lY = lY + 2
      pDrawOneLine hdc, tR.left, tR.Right, lY, 1, , lColor
   Case 5
      ' thin-thick-thin
      lY = tR.tOp + (tR.Bottom - tR.tOp) \ 2 - 2
      lY = lY - 3
      pDrawOneLine hdc, tR.left, tR.Right, lY, 1, , lColor
      lY = lY + 3
      pDrawOneLine hdc, tR.left, tR.Right, lY, 2, , lColor
      lY = lY + 2
      pDrawOneLine hdc, tR.left, tR.Right, lY, 1, , lColor
   End Select
   
End Sub

Private Sub pDrawOneLine(ByVal hdc As Long, ByVal lXStart As Long, ByVal lXEnd
 As Long, ByVal lY As Long, ByVal lWidth As Long, Optional ByVal lStyle As Long
 = PS_SOLID, Optional ByVal lColor As Long = COLOR_WINDOWTEXT)
Dim hPen As Long
Dim hPenOld As Long
Dim tP As POINTAPI
Dim tLB As LOGBRUSH

   tLB.lbColor = GetSysColor(lColor)
   hPen = ExtCreatePen(PS_GEOMETRIC Or PS_ENDCAP_FLAT Or lStyle, lWidth, tLB,
    0, ByVal 0&)
   hPenOld = SelectObject(hdc, hPen)
   BeginPath hdc
   MoveToEx hdc, lXStart, lY, tP
   LineTo hdc, lXEnd, lY
   EndPath hdc
   StrokePath hdc
   SelectObject hdc, hPenOld
   DeleteObject hPen

End Sub
Private Sub pDrawSelectedLine(ByVal lMenuIndex As Long, ByVal lColor As Long)
Dim tR As RECT
   picDemo.Cls
   GetClientRect picDemo.hwnd, tR
   InflateRect tR, -4, -4
   pDrawLine picDemo.hdc, lMenuIndex, tR, lColor
End Sub

Private Sub c_DrawItem(ByVal hdc As Long, ByVal lMenuIndex As Long, lLeft As
 Long, lTop As Long, lRight As Long, lBottom As Long, ByVal bSelected As
 Boolean, ByVal bChecked As Boolean, ByVal bDisabled As Boolean, bDoDefault As
 Boolean)
Dim tR As RECT
Dim tTXR As RECT
Dim sText As String
Dim hBrush As Long
Dim lColor As Long

   ' This event is sent whenever the menu wants to draw an item.
   bDoDefault = False
   
   ' First, set backmode to transparent and store the rectangle:
   SetBkMode hdc, TRANSPARENT
   tR.left = lLeft
   tR.tOp = lTop
   tR.Bottom = lBottom
   tR.Right = lRight
   
   ' Fill the background of the menu:
   If (bSelected) Then
       hBrush = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
       lColor = COLOR_HIGHLIGHTTEXT
       SetTextColor hdc, GetSysColor(lColor)
   Else
       hBrush = CreateSolidBrush(GetSysColor(COLOR_MENU))
       lColor = COLOR_MENUTEXT
       SetTextColor hdc, GetSysColor(lColor)
   End If
   FillRect hdc, tR, hBrush
   DeleteObject hBrush
      
   ' If the item to be drawn is a real menu item:
   If (lMenuIndex <> -1) Then
   
      ' Draw as required:
      Select Case m_sCurrentMenu
      Case "LineStyle"
         
         sText = c.Caption(lMenuIndex)
         LSet tTXR = tR
         tTXR.left = tTXR.left + tTXR.Bottom - tTXR.tOp
         tTXR.Right = tTXR.left + 24
         DrawText hdc, sText, -1, tTXR, DT_LEFT
         
         If (c.Checked(lMenuIndex)) Then
            DrawIcon hdc, tR.left + 2, tR.tOp + (tR.Bottom - tR.tOp - 14) \ 2,
             imgTick.Picture.Handle
         End If
         
         tR.left = tTXR.Right
         tR.Right = tR.Right - 4
             
         pDrawLine hdc, lMenuIndex, tR, lColor
         
      Case "Highlight"
         InflateRect tR, -1, -1
         tR.left = tR.left + 16
         If bSelected Then
            If c.Checked(lMenuIndex) Then
               DrawIcon hdc, tR.left - 14, tR.tOp + (tR.Bottom - tR.tOp - 14) \
                2, imgPointNow.Picture.Handle
            Else
               DrawIcon hdc, tR.left - 14, tR.tOp + (tR.Bottom - tR.tOp - 14) \
                2, imgPoint.Picture.Handle
            End If
         Else
            If c.Checked(lMenuIndex) Then
               DrawIcon hdc, tR.left - 14, tR.tOp + (tR.Bottom - tR.tOp - 14) \
                2, imgTick.Picture.Handle
            End If
         End If
         If bSelected Or c.Caption(lMenuIndex) = "None" Then
            DrawEdge hdc, tR, BDR_SUNKENOUTER, BF_RECT
            InflateRect tR, -1, -1
         End If
         hBrush = CreateSolidBrush(c.ItemData(lMenuIndex))
         FillRect hdc, tR, hBrush
         DeleteObject hBrush
         If c.Caption(lMenuIndex) = "None" Then
            SetTextColor hdc, GetSysColor(vb3DDKShadow And &H1F&)
            tR.left = tR.left + 2
            DrawText hdc, "None", 4, tR, DT_VCENTER Or DT_SINGLELINE
         End If

      End Select
   End If
    

End Sub

Private Sub c_MeasureItem(ByVal lMenuIndex As Long, lWidth As Long, lHeight As
 Long)
   ' This event is fired whenever the cNewMenu DLL is about to show
   ' a menu item for the first time.  The DLL will fill in Width and
   ' Height based on the caption and assuming there is an icon to
   ' the left of the caption.
   
   ' Here we Override the default width and height properties for the
   ' menu items:
   lWidth = (cmdLinePicker.Width * 2) \ Screen.TwipsPerPixelX
   lHeight = lHeight - 4
   
End Sub

Private Sub cmdHighlight_Click()
Dim lR As Long
Dim i As Long
   ' Restore the highlight menu:
   m_sCurrentMenu = "Highlight"
   ' Set a flag so we know what to do during the DrawItem event:
   c.Restore m_sCurrentMenu
   ' Show it:
   lR = c.ShowPopupMenu(cmdHighlight.left, cmdHighlight.tOp +
    cmdHighlight.Height)
   If (lR > 0) Then
      ' If we clicked an item, set it checked and display the demo
      ' on screen:
      For i = 1 To c.Count
         c.Checked(i) = (i = lR)
      Next i
      ' We need to save the state so the checked states are stored:
      c.Store "Highlight"
      ' Show the demo:
      If (c.Caption(lR) = "None") Then
         picDemo.BackColor = vbWindowBackground
      Else
         picDemo.BackColor = c.ItemData(lR)
      End If
   End If
   
End Sub

Private Sub cmdLinePicker_Click()
Dim lR As Long
Dim i As Long
   ' Restore the linestyle menu:
   m_sCurrentMenu = "LineStyle"
   ' Set a flag so we know what to do during the DrawItem event:
   c.Restore m_sCurrentMenu
   lR = c.ShowPopupMenu(cmdLinePicker.left, cmdLinePicker.tOp +
    cmdLinePicker.Height)
   If (lR > 0) Then
      ' If we clicked an item, set it checked and display the demo
      ' on screen:
      For i = 1 To c.Count
         c.Checked(i) = (i = lR)
      Next i
      ' We need to save the state so the checked states are stored:
      c.Store "LineStyle"
      ' Show the demo:
      pDrawSelectedLine lR, COLOR_MENUTEXT
   End If
   
End Sub


Private Sub Form_Load()
Dim i As Long

   Set c = New cPopupMenu
   With c
      .hWndOwner = Me.hwnd
      
      ' Create menus for line style picker:
      .AddItem "", , 1, bChecked:=True, sKey:="25"
      .AddItem "", , 1, sKey:="50"
      .AddItem "", , 1, sKey:="75"
      .AddItem "1", , 1, sKey:="100"
      .AddItem "1", , 1, sKey:="150"
      .AddItem "2", , 1, sKey:="225"
      .AddItem "3", , 1, sKey:="300"
      .AddItem "4", , 1, sKey:="450"
      .AddItem "6", , 1, sKey:="600"
      
      .AddItem "3", , 2, sKey:="100"
      .AddItem "4", , 3, sKey:="150"
      .AddItem "4", , 4, sKey:="150"
      .AddItem "6", , 5, sKey:="150"
        
      ' Set all the items to Owner-Draw:
      For i = 1 To c.Count
         c.OwnerDraw(i) = True
      Next i
      ' Show a sample line:
      pDrawSelectedLine 1, COLOR_MENUTEXT
      ' Store this menu:
      .Store "LineStyle"
      
      ' Clear to create a menu for highlight:
      .Clear
      .AddItem "None", , GetSysColor(COLOR_MENU)
      .AddItem "", , &H80FFFF
      .AddItem "", , &H80FF80
      .AddItem "", , &HFFFF00
      .AddItem "", , &HFF00FF
      ' Set all items to Owner-Draw:
      For i = 1 To c.Count
         c.OwnerDraw(i) = True
      Next i
      ' Store this menu:
      .Store "Highlight"
   End With
End Sub