VB5 ToolBox ListBar Control Binary (30K)
VB5 ToolBox ListBar Demonstration (18K)
VB5 ToolBox ListBar Full Source (75K)
VB6 ToolBox ListBar Control Binary (30K)
VB6 ToolBox ListBar Demonstration (17K)
VB6 ToolBox ListBar Full Source (74K)
Bugs: 3 / 3
Issues: 0 / 0
Questions: 0 / 0
12 Feb 2003
First Posted
vbAccelerator Visual Studio Style Tab Control
vbAccelerator - Contents of code file: frmTestToolBoxBar.frm
VERSION 5.00
Object = "{3A709943-58E7-4A77-9E5B-D5333AC98098}#1.1#0"; "vbalToolboxBar6.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmTestToolBoxBar
Caption = "vbAccelerator ToolBox ListBar Control"
ClientHeight = 4695
ClientLeft = 3855
ClientTop = 3360
ClientWidth = 6645
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmTestToolBoxBar.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4695
ScaleWidth = 6645
Begin MSComctlLib.ImageList ilsIcons
Left = 5280
Top = 1380
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483633
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 19
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1272
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":13CC
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1526
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1680
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":17DA
Key = ""
EndProperty
BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1934
Key = ""
EndProperty
BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1A8E
Key = ""
EndProperty
BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1BE8
Key = ""
EndProperty
BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1D42
Key = ""
EndProperty
BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1E9C
Key = ""
EndProperty
BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":1FF6
Key = ""
EndProperty
BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":2150
Key = ""
EndProperty
BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":22AA
Key = ""
EndProperty
BeginProperty ListImage14 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":2404
Key = ""
EndProperty
BeginProperty ListImage15 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":255E
Key = ""
EndProperty
BeginProperty ListImage16 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":26B8
Key = ""
EndProperty
BeginProperty ListImage17 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":2812
Key = ""
EndProperty
BeginProperty ListImage18 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":296C
Key = ""
EndProperty
BeginProperty ListImage19 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmTestToolBoxBar.frx":2AC6
Key = ""
EndProperty
EndProperty
End
Begin vbalToolboxBar6.vbalToolBoxBarCtl tbxLeft
Align = 3 'Align Left
Height = 4695
Left = 0
TabIndex = 9
Top = 0
Width = 2655
_ExtentX = 4683
_ExtentY = 8281
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.CommandButton cmdNewInstance
Caption = "&New Form..."
Height = 435
Left = 4920
TabIndex = 8
Top = 600
Width = 1215
End
Begin VB.Frame fraBar
Caption = "Bar Properties"
Height = 1935
Left = 2760
TabIndex = 2
Top = 60
Width = 2055
Begin VB.CheckBox chkItemsEnabled
Caption = "Items E&nabled"
Height = 255
Left = 180
TabIndex = 7
Top = 1560
Width = 1695
End
Begin VB.CheckBox chkSorted
Caption = "&Sorted"
Height = 255
Left = 180
TabIndex = 6
Top = 1260
Width = 1695
End
Begin VB.CheckBox chkVisible
Caption = "&Visible"
Height = 255
Left = 180
TabIndex = 5
Top = 960
Width = 1695
End
Begin VB.CheckBox chkListStyle
Caption = "&List Style"
Height = 255
Left = 180
TabIndex = 4
Top = 660
Width = 1695
End
Begin VB.ComboBox cboBar
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 3
Top = 240
Width = 1815
End
End
Begin VB.TextBox txtDragDrop
Height = 2295
Left = 2760
MultiLine = -1 'True
OLEDropMode = 1 'Manual
ScrollBars = 2 'Vertical
TabIndex = 1
Text = "frmTestToolBoxBar.frx":2C20
Top = 2280
Width = 3795
End
Begin VB.CommandButton cmdNext
Caption = "Select Next"
Height = 435
Left = 4920
TabIndex = 0
Top = 60
Width = 1215
End
Begin VB.Menu mnuContextTop
Caption = ""
Visible = 0 'False
Begin VB.Menu mnuContext
Caption = "&Delete Tab..."
Index = 0
End
Begin VB.Menu mnuContext
Caption = "&Rename Tab..."
Index = 1
End
Begin VB.Menu mnuContext
Caption = "Cu&t"
Index = 2
Visible = 0 'False
End
Begin VB.Menu mnuContext
Caption = "&Copy"
Index = 3
Visible = 0 'False
End
Begin VB.Menu mnuContext
Caption = "&Paste"
Index = 4
Visible = 0 'False
End
Begin VB.Menu mnuContext
Caption = "&Delete"
Index = 5
Visible = 0 'False
End
Begin VB.Menu mnuContext
Caption = "-"
Index = 6
End
Begin VB.Menu mnuContext
Caption = "&Add Tab"
Index = 7
End
Begin VB.Menu mnuContext
Caption = "S&ort Items Alphabetically"
Index = 8
End
Begin VB.Menu mnuContext
Caption = "&Show All Tabs"
Index = 9
End
Begin VB.Menu mnuContext
Caption = "&List View"
Index = 10
End
Begin VB.Menu mnuContext
Caption = "-"
Index = 11
End
Begin VB.Menu mnuContext
Caption = "Move &Up"
Index = 12
End
Begin VB.Menu mnuContext
Caption = "Move &Down"
Index = 13
End
End
End
Attribute VB_Name = "frmTestToolBoxBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_sComboKey() As String
Private m_cMenuBar As cToolBoxBar
Private m_cMenuItem As cToolItem
Private Sub addItems(cBar As cToolBoxBar)
Dim i As Long
Dim lSize As Long
If (cBar.Index = 1) Then
lSize = ilsIcons.ListImages.Count
Else
lSize = Rnd * ilsIcons.ListImages.Count
End If
For i = 1 To lSize
cBar.Items.Add "ITEM" & i & ":" & cBar.Index, , "Item " & i, i - 1
Next i
End Sub
Private Sub cboBar_Click()
cboBar.Tag = "NOSET"
With tbxLeft.Bars(m_sComboKey(cboBar.ListIndex))
chkListStyle.Value = Abs(.ListStyle)
chkVisible.Value = Abs(.Visible)
chkSorted.Value = Abs(.Sorted)
chkItemsEnabled.Enabled = (.Items.Count > 0)
If (.Items.Count > 0) Then
chkItemsEnabled.Value = Abs(.Items(1).Enabled)
End If
End With
cboBar.Tag = ""
End Sub
Private Sub chkItemsEnabled_Click()
If (cboBar.Tag = "") Then
Dim i As Long
With tbxLeft.Bars(m_sComboKey(cboBar.ListIndex)).Items
For i = 1 To .Count
.Item(i).Enabled = (chkItemsEnabled.Value = vbChecked)
Next i
End With
cboBar_Click
End If
End Sub
Private Sub chkListStyle_Click()
If (cboBar.Tag = "") Then
tbxLeft.Bars(m_sComboKey(cboBar.ListIndex)).ListStyle =
(chkListStyle.Value = vbChecked)
cboBar_Click
End If
End Sub
Private Sub chkSorted_Click()
If (cboBar.Tag = "") Then
tbxLeft.Bars(m_sComboKey(cboBar.ListIndex)).Sorted = (chkSorted.Value =
vbChecked)
cboBar_Click
End If
End Sub
Private Sub chkVisible_Click()
If (cboBar.Tag = "") Then
tbxLeft.Bars(m_sComboKey(cboBar.ListIndex)).Visible = (chkVisible.Value =
vbChecked)
cboBar_Click
End If
End Sub
Private Sub cmdNewInstance_Click()
Dim f As New frmTestToolBoxBar
f.Show
End Sub
Private Sub cmdNext_Click()
Dim l As Long
If Not (tbxLeft.SelectedBar Is Nothing) Then
Dim cNext As cToolBoxBar
Dim lIndex As Long
Set cNext = tbxLeft.SelectedBar.NextBar
If (cNext Is Nothing) Then
' Off the bottom:
If (tbxLeft.Bars(1).Visible) Then
lIndex = 1
Else
Set cNext = tbxLeft.Bars(1).NextBar
If Not (cNext Is Nothing) Then
lIndex = cNext.Index
Else
' no visible bars:
Exit Sub
End If
End If
Else
lIndex = cNext.Index
End If
tbxLeft.Bars(lIndex).Selected = True
End If
End Sub
Private Sub Form_Load()
Dim cBar As cToolBoxBar
Dim cItem As cToolItem
tbxLeft.ImageList = ilsIcons
Set cBar = tbxLeft.Bars.Add("COMPONENTS", , "Components")
addItems cBar
Set cBar = tbxLeft.Bars.Add("DATA", , "Data")
addItems cBar
Set cBar = tbxLeft.Bars.Add("GENERAL", , "General")
addItems cBar
Set cBar = tbxLeft.Bars.Add("WINDOWFORM", , "Windows Forms")
addItems cBar
Set cBar = tbxLeft.Bars.Add("CLIPBOARD", , "Clipboard Ring")
cBar.Items.Add "C1", , Clipboard.GetText
Dim i As Long
ReDim m_sComboKey(0 To tbxLeft.Bars.Count - 1) As String
For i = 1 To tbxLeft.Bars.Count
cboBar.AddItem tbxLeft.Bars(i).Caption
m_sComboKey(i - 1) = tbxLeft.Bars(i).Key
Next i
cboBar.ListIndex = 0
End Sub
Private Sub mnuContext_Click(Index As Integer)
Dim sI As String
Dim i As Long
Select Case Index
Case 0
' delete
If (vbYes = MsgBox("Are you sure you want to delete the tab " &
m_cMenuBar.Caption & "?", vbYesNo Or vbQuestion)) Then
tbxLeft.Bars.Remove m_cMenuBar.Key
End If
Case 1
' rename
If (m_cMenuItem Is Nothing) Then
sI = InputBox("Enter the the new name for tab " & m_cMenuBar.Caption,
App.Title)
If (Len(sI) > 0) Then
m_cMenuBar.Caption = sI
End If
Else
sI = InputBox("Enter the new name for item " & m_cMenuItem.Caption,
App.Title)
If (Len(sI) > 0) Then
m_cMenuItem.Caption = sI
End If
End If
Case 2
Case 3
Case 4
Case 5
' delete item
If (vbYes = MsgBox("Are you sure you want to delete the item " &
m_cMenuItem.Caption & "?", vbYesNo Or vbQuestion)) Then
tbxLeft.Bars(m_cMenuBar.Key).Items.Remove m_cMenuItem.Key
End If
Case 7
' add
sI = InputBox("Enter the new tab name:", App.Title)
If (Len(sI) > 0) Then
tbxLeft.Bars.Add "USER" & tbxLeft.Bars.Count, , sI
End If
Case 8
' sort
mnuContext(Index).Checked = Not (mnuContext(Index).Checked)
m_cMenuBar.Sorted = mnuContext(Index).Checked
Case 9
' show all
For i = 1 To tbxLeft.Bars.Count
tbxLeft.Bars(i).Visible = True
Next i
Case 10
' list view
mnuContext(Index).Checked = Not (mnuContext(Index).Checked)
m_cMenuBar.ListStyle = mnuContext(Index).Checked
Case 12
' move up
If (m_cMenuItem Is Nothing) Then
m_cMenuBar.MovePrevious
Else
m_cMenuItem.MovePrevious
End If
Case 13
' move down
If (m_cMenuItem Is Nothing) Then
m_cMenuBar.MoveNext
Else
m_cMenuItem.MoveNext
End If
End Select
End Sub
Private Sub tbxLeft_BarClick(Bar As cToolBoxBar, ByVal Button As
MouseButtonConstants, ByVal Shift As ShiftConstants, ByVal x As Single, ByVal
y As Single)
If (Button = vbRightButton) Then
Set m_cMenuBar = Bar
Set m_cMenuItem = Nothing
mnuContext(0).Visible = True
mnuContext(1).Caption = "Re&name Tab"
mnuContext(2).Visible = False
mnuContext(3).Visible = False
mnuContext(4).Visible = False
mnuContext(5).Visible = False
' Move up:
mnuContext(12).Enabled = Not (Bar.PreviousBar Is Nothing)
' Move down:
mnuContext(13).Enabled = Not (Bar.NextBar Is Nothing)
' Sort
mnuContext(8).Checked = (Bar.Sorted)
' ListView
mnuContext(10).Checked = (Bar.ListStyle)
Me.PopupMenu mnuContextTop, , x, y
End If
End Sub
Private Sub tbxLeft_BarSelected(Bar As cToolBoxBar)
Dim i As Long
For i = 0 To cboBar.ListCount - 1
If (m_sComboKey(i) = Bar.Key) Then
cboBar.ListIndex = i
Exit For
End If
Next i
End Sub
Private Sub tbxLeft_ItemClick(Item As cToolItem, ByVal Button As
MouseButtonConstants, ByVal Shift As ShiftConstants, ByVal x As Single, ByVal
y As Single)
If (Button = vbRightButton) Then
If (Item Is Nothing) Then
If Not (tbxLeft.SelectedBar Is Nothing) Then
If Not (tbxLeft.SelectedBar.SelectedItem Is Nothing) Then
Set Item = tbxLeft.SelectedBar.SelectedItem
Else
Exit Sub
End If
Else
Exit Sub
End If
Item.EnsureVisible
End If
Set m_cMenuBar = Item.OwnerBar
Set m_cMenuItem = Item
mnuContext(0).Visible = False
mnuContext(1).Caption = "Re&name Item"
mnuContext(2).Visible = True
mnuContext(3).Visible = True
mnuContext(4).Visible = True
mnuContext(5).Visible = True
' Move up:
mnuContext(12).Enabled = Not (Item.PreviousItem Is Nothing)
' Move down:
mnuContext(13).Enabled = Not (Item.NextItem Is Nothing)
' Sort
mnuContext(8).Checked = (m_cMenuBar.Sorted)
' ListView
mnuContext(10).Checked = (m_cMenuBar.ListStyle)
Me.PopupMenu mnuContextTop, , x, y
End If
End Sub
Private Sub tbxLeft_ItemDblClick(Item As cToolItem, ByVal Button As
MouseButtonConstants, ByVal Shift As ShiftConstants, ByVal x As Single, ByVal
y As Single)
MsgBox "Double-clicked " & Item.Caption, vbInformation
End Sub
Private Sub tbxLeft_KeyPress(KeyAscii As Integer)
If (KeyAscii = vbKeyReturn) Then
If Not (tbxLeft.SelectedBar.SelectedItem Is Nothing) Then
MsgBox "Return on " & tbxLeft.SelectedBar.SelectedItem.Caption,
vbInformation
End If
End If
End Sub
Private Sub txtDragDrop_OLECompleteDrag(Effect As Long)
Debug.Print "OLECompleteDrag"
End Sub
Private Sub txtDragDrop_OLEDragDrop(Data As DataObject, Effect As Long, Button
As Integer, Shift As Integer, x As Single, y As Single)
Debug.Print "OLEDragDrop"
Dim b() As Byte
Effect = vbDropEffectNone
If (Data.GetFormat(tbbCfItemIdentifier)) Then
b = Data.GetData(tbbCfItemIdentifier)
Dim cT As cToolItem
Set cT = tbxLeft.ItemFromDragData(b)
If (cT.Enabled) Then
If (cT.OwnerBar.Key = "CLIPBOARD") Then
Effect = vbDropEffectCopy
txtDragDrop.SelText = cT.Caption
End If
End If
End If
End Sub
Private Sub txtDragDrop_OLEDragOver(Data As DataObject, Effect As Long, Button
As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
Dim b() As Byte
Effect = vbDropEffectNone
If (Data.GetFormat(tbbCfItemIdentifier)) Then
b = Data.GetData(tbbCfItemIdentifier)
Dim cT As cToolItem
Set cT = tbxLeft.ItemFromDragData(b)
If (cT.Enabled) And (cT.OwnerBar.Key = "CLIPBOARD") Then
Effect = vbDropEffectCopy
End If
End If
End Sub