vbAccelerator - Contents of code file: frmMenuColourPick.frm

VERSION 5.00
Object = "{8245A918-4CF7-11D2-8E21-10B404C10000}#8.0#0"; "vbalIml.ocx"
Object = "{A22D979F-2684-11D2-8E21-10B404C10000}#1.4#0"; "cPopMenu.ocx"
Begin VB.Form frmMenuColourPick 
   Caption         =   "Menu Colour Picker Demonstration"
   ClientHeight    =   4185
   ClientLeft      =   3180
   ClientTop       =   2895
   ClientWidth     =   6585
   Icon            =   "frmMenuColourPick.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4185
   ScaleWidth      =   6585
   Begin cPopMenu.PopMenu ctlPopMenu 
      Left            =   1320
      Top             =   660
      _ExtentX        =   1058
      _ExtentY        =   1058
      HighlightCheckedItems=   0   'False
      TickIconIndex   =   0
   End
   Begin VB.CommandButton cmdShow 
      Caption         =   "&Show"
      Height          =   375
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   1095
   End
   Begin vbalIml.vbalImageList ilsIcons 
      Left            =   1980
      Top             =   660
      _ExtentX        =   953
      _ExtentY        =   953
      ColourDepth     =   24
      Size            =   0
      Images          =   0
   End
   Begin VB.Label lblDemo 
      BorderStyle     =   1  'Fixed Single
      Caption         =   " vbAccelerator!"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   1200
      TabIndex        =   1
      Top             =   60
      Width           =   5295
   End
   Begin VB.Menu mnuColourTOP 
      Caption         =   "&Colours"
      Begin VB.Menu mnuColours 
         Caption         =   "&Foreground"
         Index           =   0
         Begin VB.Menu mnuForeColour 
            Caption         =   ""
         End
      End
      Begin VB.Menu mnuColours 
         Caption         =   "&Background"
         Index           =   1
         Begin VB.Menu mnuBackColour 
            Caption         =   ""
         End
      End
   End
End
Attribute VB_Name = "frmMenuColourPick"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) 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 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 CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
 lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
 Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Const COLOR_MENU = 4

Private Sub MakeColourChart()
Dim lhDCDesk As Long
Dim lhDC As Long
Dim lhBmp As Long
Dim lhBmpOld As Long
Dim lColourDepth As Long
Dim tR As RECT, tTR As RECT
Dim lWidth As Long
Dim i As Long, r As Long, g As Long, b As Long
Dim hBrush As Long
   
   lColourDepth = ilsIcons.SystemColourDepth
   If (lColourDepth <= 8) Then
      ilsIcons.ColourDepth = ILC_COLOR
      lWidth = 16
   Else
      ilsIcons.ColourDepth = ILC_COLOR24
      lWidth = 232
   End If
   
   ' Make a compatible DC:
   lhDC = CreateCompatibleDC(Me.hdc)
   DeleteDC lhDCDesk
   lhBmp = CreateCompatibleBitmap(Me.hdc, lWidth * ilsIcons.IconSizeX,
    ilsIcons.IconSizeY)
   lhBmpOld = SelectObject(lhDC, lhBmp)
   tR.bottom = ilsIcons.IconSizeY
   tR.left = 0
   tR.right = lWidth * ilsIcons.IconSizeX
   hBrush = GetSysColorBrush(COLOR_MENU)
   FillRect lhDC, tR, hBrush
   DeleteObject hBrush
   tR.right = ilsIcons.IconSizeX - 1
   For i = 1 To 16
      hBrush = CreateSolidBrush(QBColor(i - 1))
      FillRect lhDC, tR, hBrush
      DeleteObject hBrush
      tR.left = tR.left + ilsIcons.IconSizeX
      tR.right = tR.left + ilsIcons.IconSizeX
   Next i
   If (lWidth > 16) Then
      ReDim lColors(0 To 5) As Long
      lColors(0) = &H0
      lColors(1) = &H33
      lColors(2) = &H66
      lColors(3) = &H99
      lColors(4) = &HCC
      lColors(5) = &HFF
      For r = 0 To 5
         For g = 0 To 5
            For b = 0 To 5
               hBrush = CreateSolidBrush(RGB(lColors(r), lColors(g),
                lColors(b)))
               LSet tTR = tR
               tTR.right = tTR.right - 2
               tTR.bottom = tTR.bottom - 1
               FillRect lhDC, tTR, hBrush
               DeleteObject hBrush
               tR.left = tR.left + ilsIcons.IconSizeX
               tR.right = tR.left + ilsIcons.IconSizeX
            Next b
         Next g
      Next r
   End If
   
   SelectObject lhDC, lhBmpOld
   
   ilsIcons.AddFromHandle lhBmp, IMAGE_BITMAP, , vbMenuBar

   DeleteObject lhBmp
   DeleteObject lhDC

End Sub

Private Sub Command1_Click()
Dim x As Long
Dim y As Long
Dim i As Long
   y = (cmdShow.top + cmdShow.Height * 2) \ Screen.TwipsPerPixelY
   x = 16
   For i = 1 To ilsIcons.ImageCount
      ilsIcons.DrawImage i, Me.hdc, x, y
      x = x + 18
      If (x > Me.ScaleWidth \ Screen.TwipsPerPixelX - 16) Then
         x = 16
         y = y + 18
      End If
   Next i
End Sub

Private Sub cmdShow_Click()
Dim lR As Long
   lR = ctlPopMenu.ShowPopupMenu(cmdShow, "mnuColours(0)", 0, cmdShow.Height)
End Sub

Private Sub ctlPopMenu_Click(ItemNumber As Long)
Dim sKey As String
Dim iItem As Long
Dim i As Long

   sKey = ctlPopMenu.MenuKey(ItemNumber)
   If InStr(sKey, "ForeColour") <> 0 Then
      iItem = CLng(Mid$(sKey, 11))
      ctlPopMenu.Checked(ItemNumber) = True
      lblDemo.ForeColor = ctlPopMenu.ItemData(ItemNumber)
      For i = 1 To ilsIcons.ImageCount
         If (iItem <> i) Then
            ctlPopMenu.Checked("ForeColour" & i) = False
         End If
      Next i
   ElseIf InStr(sKey, "BackColour") <> 0 Then
      iItem = CLng(Mid$(sKey, 11))
      ctlPopMenu.Checked(ItemNumber) = True
      lblDemo.BackColor = ctlPopMenu.ItemData(ItemNumber)
      For i = 1 To ilsIcons.ImageCount
         If (iItem <> i) Then
            ctlPopMenu.Checked("BackColour" & i) = False
         End If
      Next i
   End If
End Sub
Private Sub AddColours(ByVal sKeyBit As String, ByVal lParentIndex As Long)
Dim sPrefix As String
Dim i As Long
Dim r As Long, g As Long, b As Long
Dim lIndex As Long
   
   ReDim lColors(0 To 5) As Long
   lColors(0) = &H0
   lColors(1) = &H33
   lColors(2) = &H66
   lColors(3) = &H99
   lColors(4) = &HCC
   lColors(5) = &HFF

   With ctlPopMenu
      .ClearSubMenusOfItem lParentIndex
      For i = 1 To ilsIcons.ImageCount
         If ((i - 1) Mod 12) = 0 Then
            sPrefix = "^"
         Else
            sPrefix = ""
         End If
         lIndex = .AddItem(sPrefix, sKeyBit & "Colour" & i, , , lParentIndex, i
          - 1)
         If (i < 17) Then
            .ItemData(lIndex) = QBColor(i - 1)
         Else
            .ItemData(lIndex) = RGB(lColors(r), lColors(g), lColors(b))
            b = b + 1
            If (b = 6) Then
               b = 0
               g = g + 1
               If (g = 6) Then
                  g = 0
                  r = r + 1
               End If
            End If
         End If
      Next i
   End With
   
End Sub

Private Sub Form_Load()
Dim lParent As Long

   MakeColourChart
   With ctlPopMenu
      .SubClassMenu Me
      .ImageList = ilsIcons.hIml
      lParent = .MenuIndex("mnuColours(0)")
      AddColours "Fore", lParent
      lParent = .MenuIndex("mnuColours(1)")
      AddColours "Back", lParent
   End With
   
End Sub