VB5 Transparent Menu Demonstration (32K)
VB6 Transparent Menu Demonstration (31K)
25 Nov 2002
First Posted
Subclassing Without The Crashes
vbAccelerator - Contents of code file: frmTransparentMenu.frm
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.2#0"; "COMCTL32.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 ComctlLib.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
