vbAccelerator - Contents of code file: frmTransparentMenu.frm

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmTransparentMenu 
   Caption         =   "Transparent Menu Demonstration"
   ClientHeight    =   4260
   ClientLeft      =   3135
   ClientTop       =   2700
   ClientWidth     =   5865
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTransparentMenu.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4260
   ScaleWidth      =   5865
   Begin VB.TextBox txtInfo 
      Height          =   3015
      Left            =   60
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   2
      Text            =   "frmTransparentMenu.frx":1272
      Top             =   600
      Width           =   5715
   End
   Begin VB.CommandButton cmdVBAccel 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   60
      Picture         =   "frmTransparentMenu.frx":14AA
      Style           =   1  'Graphical
      TabIndex        =   0
      ToolTipText     =   "Connect to vbAccelerator - the VB Programmer's
       Resource"
      Top             =   60
      Width           =   1275
   End
   Begin MSComctlLib.ImageList ilsIcons16 
      Left            =   5100
      Top             =   3540
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   43
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":1A71
            Key             =   "PASTE"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":1D8B
            Key             =   "CUT"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":20A5
            Key             =   "COPY"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":23BF
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":26D9
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":29F3
            Key             =   ""
         EndProperty
         BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":2D0D
            Key             =   ""
         EndProperty
         BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":3027
            Key             =   ""
         EndProperty
         BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":3341
            Key             =   ""
         EndProperty
         BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":365B
            Key             =   ""
         EndProperty
         BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":3975
            Key             =   ""
         EndProperty
         BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":3C8F
            Key             =   ""
         EndProperty
         BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":3FA9
            Key             =   ""
         EndProperty
         BeginProperty ListImage14 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":42C3
            Key             =   ""
         EndProperty
         BeginProperty ListImage15 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":45DD
            Key             =   ""
         EndProperty
         BeginProperty ListImage16 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":48F7
            Key             =   ""
         EndProperty
         BeginProperty ListImage17 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":4C11
            Key             =   ""
         EndProperty
         BeginProperty ListImage18 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":4F2B
            Key             =   ""
         EndProperty
         BeginProperty ListImage19 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":5245
            Key             =   ""
         EndProperty
         BeginProperty ListImage20 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":555F
            Key             =   ""
         EndProperty
         BeginProperty ListImage21 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":5879
            Key             =   ""
         EndProperty
         BeginProperty ListImage22 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":5B93
            Key             =   ""
         EndProperty
         BeginProperty ListImage23 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":5EAD
            Key             =   ""
         EndProperty
         BeginProperty ListImage24 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":61C7
            Key             =   ""
         EndProperty
         BeginProperty ListImage25 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":64E1
            Key             =   ""
         EndProperty
         BeginProperty ListImage26 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":67FB
            Key             =   ""
         EndProperty
         BeginProperty ListImage27 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":6B15
            Key             =   ""
         EndProperty
         BeginProperty ListImage28 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":6E2F
            Key             =   ""
         EndProperty
         BeginProperty ListImage29 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":7149
            Key             =   ""
         EndProperty
         BeginProperty ListImage30 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":7463
            Key             =   ""
         EndProperty
         BeginProperty ListImage31 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":777D
            Key             =   ""
         EndProperty
         BeginProperty ListImage32 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":7A97
            Key             =   ""
         EndProperty
         BeginProperty ListImage33 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":7DB1
            Key             =   ""
         EndProperty
         BeginProperty ListImage34 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":80CB
            Key             =   ""
         EndProperty
         BeginProperty ListImage35 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":83E5
            Key             =   ""
         EndProperty
         BeginProperty ListImage36 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":86FF
            Key             =   ""
         EndProperty
         BeginProperty ListImage37 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":8A19
            Key             =   ""
         EndProperty
         BeginProperty ListImage38 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":8D33
            Key             =   ""
         EndProperty
         BeginProperty ListImage39 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":904D
            Key             =   "Web"
         EndProperty
         BeginProperty ListImage40 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":9367
            Key             =   ""
         EndProperty
         BeginProperty ListImage41 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":9681
            Key             =   ""
         EndProperty
         BeginProperty ListImage42 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":999B
            Key             =   ""
         EndProperty
         BeginProperty ListImage43 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmTransparentMenu.frx":9CB5
            Key             =   "vbAccelerator"
         EndProperty
      EndProperty
   End
   Begin VB.Label lblInfo 
      BackStyle       =   0  'Transparent
      Caption         =   "Windows 2000/XP only - allows you to make your menus
       transparent!"
      Height          =   435
      Left            =   1440
      TabIndex        =   1
      Top             =   120
      Width           =   4395
   End
End
Attribute VB_Name = "frmTransparentMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'
 ===============================================================================
=======
'
' Name:     vbAccelerator Transparent Menu Demo
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     18 February 2001
'
' Requires: cNewMenu6.DLL
'           SSUBTMR6.DLL
'           Windows 2000 or above
'
' Copyright  1998-2001 Steve McMahon for vbAccelerator
'
' Thanks to http://vbthunder.com/ for publishing the API declares for
' setting transparent Windows.
'
'
 -------------------------------------------------------------------------------
-------
' Visit vbAccelerator - advanced free source code for VB programmers
' http://vbaccelerator.com
'
 -------------------------------------------------------------7-----------------
-------

Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hdc
 As Long) As Long
Private Declare Function WindowFromDC Lib "USER32" (ByVal hdc As Long) As Long

' Thanks to VB Thunder (www.vbthunder.com) for publishing these declares
' in the article "Forms - Layers in Windows 2000."
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 Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
'Requires Windows 2000 or later:
Private Const WS_EX_LAYERED = &H80000
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
'//
'// currentlly defined blend function
'//

Private Const AC_SRC_OVER = &H0

'//
'// alpha format flags
'//
Private Const AC_SRC_ALPHA = &H1
Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
Private Const AC_SRC_NO_ALPHA = &H2
Private Const AC_DST_NO_PREMULT_ALPHA = &H10
Private Const AC_DST_NO_ALPHA = &H20

Private Declare Function SetLayeredWindowAttributes Lib "USER32" _
    (ByVal hWnd As Long, ByVal crKey As Long, _
    ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2

Private Declare Function UpdateLayeredWindow Lib "USER32" _
    (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, _
    psize As Any, ByVal hdcSrc As Long, _
    pptSrc As Any, crKey As Long, _
    ByVal pblend As Long, ByVal dwFlags As Long) As Long
Private Const ULW_COLORKEY = &H1
Private Const ULW_ALPHA = &H2
Private Const ULW_OPAQUE = &H4

Private WithEvents cP As cPopupMenu
Attribute cP.VB_VarHelpID = -1
Private WithEvents cO As cOwnerDrawContextMenu
Attribute cO.VB_VarHelpID = -1
Private cTextEdit As cTextBoxEdit
Private Const mcWEBSITE = -&H8000&

Private Function IsLayeredWindow(ByVal hWnd As Long) As Boolean
    Dim l As Long

    l = GetWindowLong(hWnd, GWL_EXSTYLE)
    If (l And WS_EX_LAYERED) = WS_EX_LAYERED Then
        IsLayeredWindow = True
    Else
        IsLayeredWindow = False
    End If
End Function

Private Sub SetLayeredWindow(ByVal hWnd As Long, _
ByVal bIsLayered As Boolean)
    Dim l As Long

    l = GetWindowLong(hWnd, GWL_EXSTYLE)

    If bIsLayered = True Then
        l = l Or WS_EX_LAYERED
    Else
        l = l And Not WS_EX_LAYERED
    End If
    SetWindowLong hWnd, GWL_EXSTYLE, l
    
    ' don't want to make the transparency effect too noticeable
    ' Alpha = 8 bits (i.e. 0-255)
    SetLayeredWindowAttributes hWnd, 0, 220, LWA_ALPHA

End Sub

Private Sub createMenus(ByVal bTransparent As Boolean)
Dim i As Long, j As Long, k As Long
Dim lIcon As Long
   With cP
      ' Create the vbAccelerator menu:
      .Clear
      k = .AddItem("TOP-0")
      
      i = .AddItem("vbAccelerator", , , k, , , , "VBACCELERATOR")
      .Header(i) = True
      lIcon = ilsIcons16.ListImages("vbAccelerator").Index - 1
      .AddItem "&vbAccelerator on the Web..." & vbTab & "F1", , , k, lIcon, , ,
       "Web"
      .Default(2) = True
      lIcon = ilsIcons16.ListImages("Web").Index - 1
      .AddItem "Add vbAccelerator Active &Channel...", , mcWEBSITE, k, lIcon, ,
       , "Channel"
      .AddItem "-Other sites", , , k
      i = .AddItem("VB Sites", , , k, lIcon)
      j = .AddItem("-VB Sites", , , i)
      .AddItem "VBWire", , mcWEBSITE, i, lIcon, , , "http://vbwire.com/"
      .AddItem "VBNet", , mcWEBSITE, i, lIcon, , , "http://www.mvps.org/mvps"
      .AddItem "CCRP", , mcWEBSITE, i, lIcon, , , "http://www.mvps.org/ccrp"
      .AddItem "DevX", , mcWEBSITE, i, lIcon, , , "http://www.devx.com/"
      i = .AddItem("Technology", , , k, lIcon)
      j = .AddItem("-Games", , , i)
      .AddItem "Dave's Classics", , mcWEBSITE, i, lIcon, , ,
       "http://www.davesclassics.com/"
      .AddItem "Future Gamer", , mcWEBSITE, i, lIcon, , ,
       "http://www.futuregamer.com/"
      .AddItem "-Web Site Building", , , i
      .AddItem "Builder.com", , mcWEBSITE, i, lIcon, , ,
       "http://www.builder.com/"
      .AddItem "The Web Design Resource", , mcWEBSITE, i, lIcon, , ,
       "http://www.pageresource.com/"
      .AddItem "Web Review", , mcWEBSITE, i, lIcon, , ,
       "http://www.webreview.com/"
      .AddItem "-Downloads", , , i
      .AddItem "CNet", , mcWEBSITE, i, lIcon, , , "http://www.cnet.com/"
      .AddItem "WinFiles.com", , mcWEBSITE, i, lIcon, , ,
       "http://www.winfiles.com/"
      i = .AddItem("Searching and Other", , , k, lIcon)
      j = .AddItem("-Pick'n'Mix", , , i)
      .AddItem "The SCHWA Corporation", , mcWEBSITE, i, lIcon, , ,
       "http://www.theschwacorporation.com/"
      .AddItem "Art Cars", , mcWEBSITE, i, lIcon, , , "http://www.artcars.com/"
      .AddItem "The Onion", , mcWEBSITE, i, lIcon, , ,
       "http://www.theonion.com/"
      .AddItem "Virtues of a Programmer", i, mcWEBSITE, i, lIcon, , ,
       "http://www.hhhh.org/wiml/virtues.html"
      j = .AddItem("-Search", , k, i)
      .AddItem "Google", , mcWEBSITE, i, lIcon, , , "http://www.google.com/"
      .AddItem "DogPile", , mcWEBSITE, i, lIcon, , , "http://www.dogpile.com/"
      
      k = .AddItem("TOP-1")
      
      i = .AddItem("&Undo", , , k, , , , "T:UNDO")
      .AddItem "-", , , k
      .AddItem "Cu&t" & vbTab & "Ctrl+X", , , k,
       ilsIcons16.ListImages("CUT").Index - 1, , , "T:CUT"
      .AddItem "&Copy" & vbTab & "Ctrl+C", , , k,
       ilsIcons16.ListImages("COPY").Index - 1, , , "T:COPY"
      .AddItem "&Paste" & vbTab & "Ctrl+V", , , k,
       ilsIcons16.ListImages("PASTE").Index - 1, , , "T:PASTE"
      .AddItem "-", , , k
      .AddItem "Select &All" & vbTab & "Ctrl+A", , , k, , , , "T:SELECTALL"
      
      For i = 1 To .Count
         .OwnerDraw(i) = True
      Next i
      
      .Store "vbAccelerator"
   End With
End Sub

Private Sub cmdVBAccel_Click()
Dim iIndex As Long
   With cP
      .Restore "vbAccelerator"
      iIndex = .ShowPopupMenuAtIndex( _
         cmdVBAccel.Left, cmdVBAccel.Top + cmdVBAccel.Height, _
         cmdVBAccel.Left, cmdVBAccel.Top, cmdVBAccel.Left + cmdVBAccel.Width,
          cmdVBAccel.Top + cmdVBAccel.Height, _
         , .IndexForKey("VBACCELERATOR") _
            )
      If (iIndex > 0) Then
         MsgBox "Selected " & cP.Caption(iIndex), vbInformation
      End If
   End With

End Sub

Private Sub cO_ContextMenu(ByVal Key As String, bDoDefault As Boolean)
   cTextEdit.TextBox = txtInfo
   cP.Enabled(cP.IndexForKey("T:CUT")) = cTextEdit.CanCut
   cP.Enabled(cP.IndexForKey("T:COPY")) = cTextEdit.CanCopy
   cP.Enabled(cP.IndexForKey("T:PASTE")) = cTextEdit.CanPaste
   cP.Enabled(cP.IndexForKey("T:UNDO")) = cTextEdit.CanUndo
End Sub

Private Sub cP_Click(ItemNumber As Long)
Dim sKey As String
   sKey = cP.ItemKey(ItemNumber)
   If Len(sKey) > 2 Then
      If Left$(sKey, 2) = "T:" Then
         Select Case Mid$(sKey, 3)
         Case "UNDO"
            cTextEdit.Undo
         Case "CUT"
            cTextEdit.Cut
         Case "COPY"
            cTextEdit.Copy
         Case "PASTE"
            cTextEdit.Paste
         Case "SELECTALL"
            txtInfo.SetFocus ' seems to be needed!
            txtInfo.SelStart = 0
            txtInfo.SelLength = Len(txtInfo.Text) - 1
         End Select
      End If
   End If
End Sub

Private Sub cP_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 lhWnd As Long
   lhWnd = WindowFromDC(hdc)
   If Not IsLayeredWindow(lhWnd) Then
      Debug.Print "Setting:", lhWnd
      SetLayeredWindow lhWnd, True
   End If
   bDoDefault = True
   
End Sub

Private Sub cP_MeasureItem(ByVal lMenuIndex As Long, lWidth As Long, lHeight As
 Long)
   ' no need to do anything
End Sub

Private Sub Form_Load()
   
   ' set up the menu:
   Set cP = New cPopupMenu
   ' If menu animations are switched on, then initial drawing isn't
   ' done on a menu.  So the transparent effect doesn't kick in
   ' until the menu is fully visible and the mouse moves over
   ' it.
   cP.NoMenuAnimation = True
   cP.hWndOwner = Me.hWnd
   cP.ImageList = ilsIcons16
   cP.MenuBackgroundColor = &HEEEEEE
   cP.ActiveMenuBackgroundColor = &H333333
   ' Set this so we get an event when an
   ' item is about to be drawn - this passes
   ' us the DC of the menu & hence we can evaluate
   ' the window handle of the menu..
   createMenus True
   
   Set cO = New cOwnerDrawContextMenu
   cO.PopupMenu = cP
   cO.Add "txtInfo", txtInfo.hWnd, "T:CUT"
   Set cTextEdit = New cTextBoxEdit
   
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   txtInfo.Move txtInfo.Left, txtInfo.Top, Me.ScaleWidth - txtInfo.Left * 2,
    Me.ScaleHeight - txtInfo.Top - txtInfo.Left
End Sub