VB5 WinZip UI Sample (225K)
VB6 WinZip UI Sample (221K)
Bugs: 0 / 1
Issues: 0 / 0
Questions: 0 / 0
25 Jan 2004
First Posted
vbAccelerator ImageList Control and Class v2.0
vbAccelerator CommandBar Control
vbAccelerator - Contents of code file: frmWinzipSample.frm
VERSION 5.00
Object = "{50403D50-4D95-4B43-B9BF-030BAB376D77}#16.0#0"; "vbalCmdBar.ocx"
Begin VB.Form frmWinzip
Caption = "vbAccelerator WinZip UI style demonstration"
ClientHeight = 5145
ClientLeft = 4365
ClientTop = 2640
ClientWidth = 6855
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmWinzipSample.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5145
ScaleWidth = 6855
Begin vbalCmdBar.vbalCommandBar cmdBar
Align = 1 'Align Top
Height = 435
Index = 0
Left = 0
Top = 0
Width = 6855
_ExtentX = 12091
_ExtentY = 767
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
Style = 0
End
Begin vbalCmdBar.vbalCommandBar cmdBar
Align = 1 'Align Top
Height = 435
Index = 1
Left = 0
Top = 435
Width = 6855
_ExtentX = 12091
_ExtentY = 767
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
Style = 0
End
End
Attribute VB_Name = "frmWinzip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_cImlToolbar As cVBALImageList
Private m_cImlMenu As cVBALImageList
' Quit gently
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal
hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_CLOSE = &HF060&
' A generic recursive procedure to create command
' bars for all subitems of the specified key.
' This works if you set up your keys in the
' appropriate way. It isn't particularly
' efficient, though.
Private Sub createCommandBarsFromKeys( _
cmdBar As vbalCommandBar, _
ByVal sStartKey As String, _
btnOwner As cButton _
)
Dim iBtn As Long
Dim bar As cCommandBar
Dim btn As cButton
Dim colStartKeyParts As Collection
Dim colParts As Collection
Set colStartKeyParts = parseKey(sStartKey)
With cmdBar.Buttons
For iBtn = 1 To .Count
Set btn = .Item(iBtn)
If (InStr(btn.Key, sStartKey & ":") = 1) Then
Set colParts = parseKey(btn.Key)
If (colParts.Count = colStartKeyParts.Count + 1) Then
If (bar Is Nothing) Then
Set bar = cmdBar.CommandBars.Add(sStartKey, sStartKey)
If Not (btnOwner Is Nothing) Then
btnOwner.bar = bar
End If
End If
bar.Buttons.Add btn
' recurse
createCommandBarsFromKeys cmdBar, btn.Key, btn
End If
End If
Next iBtn
End With
End Sub
Private Function parseKey( _
ByVal sKey As String _
) As Collection
Dim iPos As Long
Dim iNextPos As Long
Dim colParts As New Collection
iPos = 1
iNextPos = 1
Do While (iNextPos > 0)
iNextPos = InStr(iPos, sKey, ":")
If (iNextPos > 0) Then
colParts.Add Mid(sKey, iPos, iNextPos - iPos)
iPos = iNextPos + 1
End If
Loop
If (iPos > 0) Then
colParts.Add Mid(sKey, iPos)
End If
Set parseKey = colParts
End Function
Private Sub createCommandBars()
createCommandBarsFromKeys cmdBar(0), "MENU", Nothing
createCommandBarsFromKeys cmdBar(0), "TOOLBAR", Nothing
createCommandBarsFromKeys cmdBar(0), "TOOLBARCONTEXT", Nothing
End Sub
Private Sub createButtons()
Dim btn As cButton
Dim bar As cCommandBar
Dim btns As cCommandBarButtons
Dim i As Long
With cmdBar(0)
' Add the buttons:
With .Buttons
' Add top level menu buttons
Set btn = .Add("MENU:FILE", , "&File")
btn.ShowCaptionInToolbar = True
Set btn = .Add("MENU:ACTIONS", , "&Actions")
btn.ShowCaptionInToolbar = True
Set btn = .Add("MENU:OPTIONS", , "&Options")
btn.ShowCaptionInToolbar = True
Set btn = .Add("MENU:HELP", , "&Help")
btn.ShowCaptionInToolbar = True
' Add file menu:
.Add "MENU:FILE:NEW", IconIndex("NEW"), "&New Archive...", , , vbKeyN,
vbCtrlMask
.Add "MENU:FILE:OPEN", IconIndex("OPEN"), "&Open Archive...", , ,
vbKeyO, vbCtrlMask
.Add "MENU:FILE:FAVOURITE", IconIndex("FAVOURITES"), "Fa&vourite Zip
Folders...", , , vbKeyF, vbShiftMask
Set btn = .Add("MENU:FILE:CLOSE", IconIndex("CLOSE"), "Close Archive",
, , vbKeyL, vbShiftMask)
btn.Enabled = False
.Add "MENU:FILE:SEP1", , , eSeparator
Set btn = .Add("MENU:FILE:PROPERTIES", IconIndex("PROPERTIES"),
"Properties...")
btn.Enabled = False
Set btn = .Add("MENU:FILE:SHORTCUT", , "Create &Shortcut")
btn.Enabled = False
.Add "MENU:FILE:SEP2", , , eSeparator
Set btn = .Add("MENU:FILE:MOVE", , "Move Archive...", , , vbKeyF7)
btn.Enabled = False
Set btn = .Add("MENU:FILE:COPY", , "Copy Archive...", , , vbKeyF8)
btn.Enabled = False
Set btn = .Add("MENU:FILE:RENAME", , "Rename Archive...", , , vbKeyR,
vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:FILE:DELETE", , "Delete Archive...")
btn.Enabled = False
.Add "MENU:FILE:SEP3", , , eSeparator
Set btn = .Add("MENU:FILE:PRINT", IconIndex("PRINT"), "Print...", , ,
vbKeyP, vbCtrlMask)
btn.Enabled = False
Set btn = .Add("MENU:FILE:WIZARD", IconIndex("WIZARD"), "Wizard...", ,
, vbKeyW, vbShiftMask)
.Add "MENU:FILE:SEP4", , , eSeparator
Set btn = .Add("MENU:FILE:MAIL", IconIndex("MAIL"), "Mail Archive...",
, , vbKeyM, vbShiftMask)
btn.Enabled = False
.Add "MENU:FILE:SEP5", , , eSeparator
Set btn = .Add("MENU:FILE:EXIT", IconIndex("EXIT"), "E&xit", , ,
vbKeyF4, vbAltMask)
Set btn = .Add("MENU:FILE:SEP6", , , eSeparator)
btn.Visible = False
For i = 1 To 8
Set btn = .Add("MENU:FILE:MRU" & i, , "(None yet)")
btn.Visible = False
btn.Enabled = False
Next i
' Add actions menu:
Set btn = .Add("MENU:ACTIONS:ADD", IconIndex("ADD"), "&Add...", , ,
vbKeyA, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:DELETE", IconIndex("DELETE"),
"&Delete...", , , vbKeyD, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:EXTRACT", IconIndex("EXTRACT"),
"&Extract...", , , vbKeyE, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:VIEW", IconIndex("VIEW"), "&View...", , ,
vbKeyV, vbShiftMask)
btn.Enabled = False
.Add "MENU:ACTIONS:SEP1", , , eSeparator
Set btn = .Add("MENU:ACTIONS:SELECTALL", , "&Select All", , , vbKeyA,
vbCtrlMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:INVERTSEL", , "&Invert Selection")
btn.Enabled = False
.Add "MENU:ACTIONS:SEP2", , , eSeparator
Set btn = .Add("MENU:ACTIONS:SCAN", IconIndex("SCAN"), "Virus &Scan",
, , vbKeyS, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:MAKEEXE", IconIndex("MAKEEXE"), "Ma&ke
.Exe File", , , vbKeyK, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:UUENCODE", IconIndex("UUENCODE"),
"&UUencode", , , vbKeyU, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:SPLIT", IconIndex("SPLIT"), "S&plit...",
, , vbKeyH, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:ENCRYPT", IconIndex("ENCRYPT"),
"Encr&ypt", , , vbKeyY, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:TEST", IconIndex("TEST"), "&Test", , ,
vbKeyT, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:COMMENT", IconIndex("COMMENT"),
"Comme&nt...", , , vbKeyG, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:CHECKOUT", IconIndex("CHECKOUT"),
"&CheckOut...", , , vbKeyC, vbShiftMask)
btn.Enabled = False
Set btn = .Add("MENU:ACTIONS:INSTALL", IconIndex("INSTALL"),
"Install...", , , vbKeyI, vbShiftMask)
btn.Enabled = False
' Add options menu items:
.Add "MENU:OPTIONS:CONFIGURATION", IconIndex("CONFIG"),
"&Configuration..."
.Add "MENU:OPTIONS:SORT", , "Sort"
.Add "MENU:OPTIONS:SEP1", , , eSeparator
Set btn = .Add("MENU:OPTIONS:REUSE", , "&Reuse WinZip Windows")
btn.Checked = True
.Add "MENU:OPTIONS:SEP2", , , eSeparator
Set btn = .Add("MENU:OPTIONS:SAVESETTINGSEXIT", , "Save &Settings on
Exit")
btn.Checked = True
Set btn = .Add("MENU:OPTIONS:SAVESETTINGSNOW", , "Save Settings &Now")
Set btn = .Add("MENU:OPTIONS:SETDEFAULTS", , "Set Installation
&Defaults...")
.Add "MENU:OPTIONS:SEP3", , , eSeparator
.Add "MENU:OPTIONS:VIEW", , "View &Last Output..."
' Add sort menu items:
.Add "MENU:OPTIONS:SORT:NAME", , "by &Name", eRadio
.Add "MENU:OPTIONS:SORT:TYPE", , "by &Type", eRadio
.Add "MENU:OPTIONS:SORT:DATE", , "by &Date", eRadio
.Add "MENU:OPTIONS:SORT:SIZE", , "by &Size", eRadio
.Add "MENU:OPTIONS:SORT:RATIO", , "by Compression &Ratio", eRadio
.Add "MENU:OPTIONS:SORT:PACKED", , "by &Packed Size", eRadio
.Add "MENU:OPTIONS:SORT:CRC", , "by &CRC", eRadio
.Add "MENU:OPTIONS:SORT:ATTRIB", , "by &Attributes", eRadio
.Add "MENU:OPTIONS:SORT:PATH", , "by Pat&h", eRadio
Set btn = .Add("MENU:OPTIONS:SORT:ORIGINAL", , "by &Original Order",
eRadio)
btn.Checked = True
' add help menu items:
.Add "MENU:HELP:CONTENTS", IconIndex("HELP"), "&Help Contents and
Index", , , vbKeyF1, 0
.Add "MENU:HELP:TUTORIAL", , "Brief &Tutorial"
.Add "MENU:HELP:SEP1", , , eSeparator
.Add "MENU:HELP:FAQ", , "&Frequently Asked Questions"
.Add "MENU:HELP:HINTS", , "H&ints and Tips"
.Add "MENU:HELP:TIPS", , "Ti&p of the Day"
.Add "MENU:HELP:SEP2", , , eSeparator
.Add "MENU:HELP:LICENCE", , "&Licence Agreement"
.Add "MENU:HELP:ORDER", , "&Ordering Information"
.Add "MENU:HELP:SEP3", , , eSeparator
.Add "MENU:HELP:VBA", , "vb&Accelerator Homepage"
.Add "MENU:HELP:ABOUT", , "&About Winzip UI Sample..."
' toolbar context menu:
Set btn = .Add("TOOLBARCONTEXT:LARGE", , "&Large Buttons", eCheck)
btn.Checked = True
Set btn = .Add("TOOLBARCONTEXT:TEXT", , "Show &Text", eCheck)
btn.Checked = True
Set btn = .Add("TOOLBARCONTEXT:TOOLTIPS", , "Show Toolti&ps", eCheck)
btn.Checked = True
.Add "TOOLBARCONTEXT:SEP1", , , eSeparator
Set btn = .Add("TOOLBARCONTEXT:CUSTOMIZE", , "&Customize")
btn.Enabled = False
' Toolbar buttons:
Set btn = .Add("TOOLBAR:NEW", IconIndex("NEW"), "New")
btn.ShowCaptionInToolbar = True
Set btn = .Add("TOOLBAR:OPEN", IconIndex("OPEN"), "Open")
btn.ShowCaptionInToolbar = True
Set btn = .Add("TOOLBAR:FAVOURITES", IconIndex("FAVOURITES"),
"Favourites")
btn.ShowCaptionInToolbar = True
.Add "TOOLBAR:SEP1", , , eSeparator
Set btn = .Add("TOOLBAR:ADD", IconIndex("ADD"), "Add")
btn.ShowCaptionInToolbar = True
btn.Enabled = False
Set btn = .Add("TOOLBAR:EXTRACT", IconIndex("EXTRACT"), "Extract")
btn.ShowCaptionInToolbar = True
btn.Enabled = False
Set btn = .Add("TOOLBAR:ENCRYPT", IconIndex("ENCRYPT"), "Encrypt")
btn.ShowCaptionInToolbar = True
btn.Enabled = False
Set btn = .Add("TOOLBAR:VIEW", IconIndex("VIEW"), "View")
btn.ShowCaptionInToolbar = True
btn.Enabled = False
Set btn = .Add("TOOLBAR:CHECKOUT", IconIndex("CHECKOUT"), "CheckOut")
btn.ShowCaptionInToolbar = True
btn.Enabled = False
.Add "TOOLBAR:SEP2", , , eSeparator
Set btn = .Add("TOOLBAR:WIZARD", IconIndex("WIZARD"), "Wizard")
btn.ShowCaptionInToolbar = True
Set btn = .Add("TOOLBAR:PROPERTIES", IconIndex("PROPERTIES"),
"Properties")
btn.Enabled = False
btn.ShowCaptionInToolbar = True
End With
End With
End Sub
Private Sub createImages()
Dim lSetRes As Long
Dim eType As ImageTypes
Dim cResLib As cLibrary
Set cResLib = New cLibrary
cResLib.Filename = App.Path & "\WinZipUIResourceDLL.dll"
Set m_cImlMenu = New cVBALImageList
With m_cImlMenu
.ColourDepth = .SystemColourDepth
.IconSizeX = 16
.IconSizeY = 16
.Create
End With
Select Case m_cImlMenu.ColourDepth
Case ILC_COLOR32
lSetRes = 300
eType = IMAGE_ICON
Case ILC_COLOR16, ILC_COLOR24
lSetRes = 200
eType = IMAGE_BITMAP
Case Else
lSetRes = 100
eType = IMAGE_BITMAP
End Select
loadImages m_cImlMenu, cResLib, 2000 + lSetRes, eType
Set m_cImlToolbar = New cVBALImageList
With m_cImlToolbar
.ColourDepth = .SystemColourDepth
.IconSizeX = 42
If (lSetRes = 100) Then
.IconSizeY = 28
Else
.IconSizeY = 35
End If
.Create
'.AddFromFile App.Path & "\new.ico", IMAGE_ICON, "NEW"
End With
loadImages m_cImlToolbar, cResLib, 1000 + lSetRes, eType
End Sub
Private Sub loadImages( _
cIml As cVBALImageList, _
cResLib As cLibrary, _
ByVal lResPrefix As Long, _
ByVal eType As ImageTypes _
)
Dim lRes As Long
lRes = lResPrefix
With cIml
lRes = lRes + 1 ' xx01
.AddFromResourceID lRes, cResLib.hModule, eType, "ADD"
lRes = lRes + 1 ' xx02
.AddFromResourceID lRes, cResLib.hModule, eType, "CHECKOUT"
lRes = lRes + 1 ' xx03
.AddFromResourceID lRes, cResLib.hModule, eType, "CLOSE"
lRes = lRes + 1 ' xx04
.AddFromResourceID lRes, cResLib.hModule, eType, "COMMENT"
lRes = lRes + 1 ' xx05
.AddFromResourceID lRes, cResLib.hModule, eType, "CONFIG"
lRes = lRes + 1 ' xx06
.AddFromResourceID lRes, cResLib.hModule, eType, "DELETE"
lRes = lRes + 1 ' xx07
.AddFromResourceID lRes, cResLib.hModule, eType, "ENCRYPT"
lRes = lRes + 1 ' xx08
.AddFromResourceID lRes, cResLib.hModule, eType, "EXIT"
lRes = lRes + 1 ' xx09
.AddFromResourceID lRes, cResLib.hModule, eType, "EXTRACT"
lRes = lRes + 1 ' xx10
.AddFromResourceID lRes, cResLib.hModule, eType, "FAVOURITES"
lRes = lRes + 1 ' xx11
.AddFromResourceID lRes, cResLib.hModule, eType, "HELP"
lRes = lRes + 1 ' xx12
.AddFromResourceID lRes, cResLib.hModule, eType, "HISTORY"
lRes = lRes + 1 ' xx13
.AddFromResourceID lRes, cResLib.hModule, eType, "INSTALL"
lRes = lRes + 1 ' xx14
.AddFromResourceID lRes, cResLib.hModule, eType, "MAIL"
lRes = lRes + 1 ' xx15
.AddFromResourceID lRes, cResLib.hModule, eType, "MAKEEXE"
lRes = lRes + 1 ' xx16
.AddFromResourceID lRes, cResLib.hModule, eType, "NEW"
lRes = lRes + 1 ' xx17
.AddFromResourceID lRes, cResLib.hModule, eType, "OPEN"
lRes = lRes + 1 ' xx18
.AddFromResourceID lRes, cResLib.hModule, eType, "PRINT"
lRes = lRes + 1 ' xx19
.AddFromResourceID lRes, cResLib.hModule, eType, "PROPERTIES"
lRes = lRes + 1 ' xx20
.AddFromResourceID lRes, cResLib.hModule, eType, "SCAN"
lRes = lRes + 1 'xx21
.AddFromResourceID lRes, cResLib.hModule, eType, "SPLIT"
lRes = lRes + 1 ' xx22
.AddFromResourceID lRes, cResLib.hModule, eType, "TEST"
lRes = lRes + 1 ' xx23
.AddFromResourceID lRes, cResLib.hModule, eType, "UUENCODE"
lRes = lRes + 1 ' xx24
.AddFromResourceID lRes, cResLib.hModule, eType, "VIEW"
lRes = lRes + 1 ' xx25
.AddFromResourceID lRes, cResLib.hModule, eType, "WIZARD"
lRes = lRes + 1 ' xx26
.AddFromResourceID lRes, cResLib.hModule, eType, "FIND"
lRes = lRes + 1 ' xx27
.AddFromResourceID lRes, cResLib.hModule, eType, "NOTES"
End With
End Sub
Private Function IconIndex(ByVal sKey As String) As Long
Dim lIndex As Long
On Error Resume Next
lIndex = m_cImlMenu.ItemIndex(sKey) - 1
If Not (Err.Number = 0) Then
lIndex = -1
End If
Debug.Print sKey, lIndex
IconIndex = lIndex
End Function
Private Sub processMenuClick(btn As cButton, keyParts As Collection)
If (keyParts.Count > 2) Then
Select Case keyParts(2)
Case "FILE"
If (keyParts(3) = "EXIT") Then
PostMessage Me.hWnd, WM_SYSCOMMAND, SC_CLOSE, 0
Else
MsgBox "Clicked menu item " & btn.Key, vbInformation
End If
Case "ACTIONS"
MsgBox "Clicked menu item " & btn.Key, vbInformation
Case "OPTIONS"
MsgBox "Clicked menu item " & btn.Key, vbInformation
Case "HELP"
Select Case keyParts(3)
Case "VBA"
' todo
Case "ABOUT"
Dim fA As New frmAbout
fA.Show vbModal, Me
Case Else
MsgBox "Clicked menu item " & btn.Key, vbInformation
End Select
End Select
End If
End Sub
Private Sub processToolbarClick(btn As cButton, keyParts As Collection)
MsgBox "Clicked toolbar item " & btn.Key, vbInformation
End Sub
Private Sub processContextMenu(btn As cButton, keyParts As Collection)
Select Case keyParts(2)
Case "LARGE"
If (btn.Checked) Then
cmdBar(1).ToolbarImageList = m_cImlToolbar.hIml
Else
cmdBar(1).ToolbarImageList = m_cImlMenu.hIml
End If
Case "TEXT"
cmdBar(1).Redraw = False
Dim i As Long
With cmdBar(1).CommandBars("TOOLBAR").Buttons
For i = 1 To .Count
.Item(i).ShowCaptionInToolbar = btn.Checked
Next i
End With
cmdBar(1).Redraw = True
Case "TOOLTIPS"
' todo
Case "CUSTOMIZE"
' todo
End Select
End Sub
Private Sub cmdBar_ButtonClick(Index As Integer, btn As cButton)
Dim colKeyPart As Collection
Set colKeyPart = parseKey(btn.Key)
Select Case colKeyPart(1)
Case "MENU"
processMenuClick btn, colKeyPart
Case "TOOLBAR"
processToolbarClick btn, colKeyPart
Case "TOOLBARCONTEXT"
processContextMenu btn, colKeyPart
End Select
End Sub
Private Sub cmdBar_RequestNewInstance(Index As Integer, ctl As Object)
Dim iU As Long
iU = cmdBar.UBound
Load cmdBar(iU + 1)
cmdBar(iU + 1).Align = 0
Set ctl = cmdBar(iU + 1)
End Sub
Private Sub cmdBar_RightClick(Index As Integer, btn As vbalCmdBar.cButton,
ByVal x As Long, ByVal y As Long)
If (cmdBar(Index).Toolbar.Key = "TOOLBAR") Then
cmdBar(Index).ClientCoordinatesToScreen x, y
cmdBar(Index).ShowPopupMenu x, y,
cmdBar(Index).CommandBars("TOOLBARCONTEXT")
End If
End Sub
Private Sub Form_Load()
createImages
createButtons
createCommandBars
' The style setting applies to all toolbars:
cmdBar(0).Style = eComCtl32
cmdBar(0).MainMenu = True
cmdBar(0).ToolbarImageList = m_cImlToolbar.hIml
cmdBar(0).MenuImageList = m_cImlMenu.hIml
cmdBar(0).Toolbar = cmdBar(0).CommandBars("MENU")
cmdBar(1).ToolbarImageList = m_cImlToolbar.hIml
cmdBar(1).MenuImageList = m_cImlMenu.hIml
cmdBar(1).ButtonTextPosition = eButtonTextBottom
cmdBar(1).Toolbar = cmdBar(1).CommandBars("TOOLBAR")
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y
As Single)
'
'
End Sub