vbAccelerator - Contents of code file: frmIcons.frm

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmIconEx 
   Caption         =   "vbAccelerator Icon Explorer"
   ClientHeight    =   5490
   ClientLeft      =   3120
   ClientTop       =   2655
   ClientWidth     =   7800
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmIcons.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5490
   ScaleWidth      =   7800
   Begin MSComctlLib.Toolbar tbrMain 
      Align           =   1  'Align Top
      Height          =   420
      Left            =   0
      TabIndex        =   3
      Top             =   0
      Width           =   7800
      _ExtentX        =   13758
      _ExtentY        =   741
      ButtonWidth     =   609
      Appearance      =   1
      ImageList       =   "ilsToolbar"
      _Version        =   393216
      BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
         NumButtons      =   9
         BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "open"
            Object.ToolTipText     =   "Open"
            ImageIndex      =   1
         EndProperty
         BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "save"
            Object.ToolTipText     =   "Save"
            ImageIndex      =   2
         EndProperty
         BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Style           =   3
         EndProperty
         BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "properties"
            ImageIndex      =   3
         EndProperty
         BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Style           =   3
         EndProperty
         BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "large"
            Object.ToolTipText     =   "Large Icons"
            ImageIndex      =   4
            Style           =   2
            Value           =   1
         EndProperty
         BeginProperty Button7 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "small"
            Object.ToolTipText     =   "Small Icons"
            ImageIndex      =   5
            Style           =   2
         EndProperty
         BeginProperty Button8 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "list"
            Object.ToolTipText     =   "List"
            ImageIndex      =   6
            Style           =   2
         EndProperty
         BeginProperty Button9 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Key             =   "details"
            Object.ToolTipText     =   "Details"
            ImageIndex      =   7
            Style           =   2
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ImageList ilsToolbar 
      Left            =   1500
      Top             =   4920
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   7
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":0442
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":059C
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":06F6
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":0850
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":09AA
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":0B04
            Key             =   ""
         EndProperty
         BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmIcons.frx":0C5E
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.StatusBar sbrMain 
      Align           =   2  'Align Bottom
      Height          =   315
      Left            =   0
      TabIndex        =   1
      Top             =   5175
      Width           =   7800
      _ExtentX        =   13758
      _ExtentY        =   556
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   2
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            AutoSize        =   1
            Object.Width           =   10663
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ListView lvwIcons 
      Height          =   4275
      Left            =   60
      TabIndex        =   2
      Top             =   540
      Width           =   5295
      _ExtentX        =   9340
      _ExtentY        =   7541
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   2
      BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         Text            =   "Icon"
         Object.Width           =   2540
      EndProperty
      BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   1
         Text            =   "Number Of Images"
         Object.Width           =   2540
      EndProperty
   End
   Begin MSComctlLib.ImageList ilsIcons16 
      Left            =   120
      Top             =   4920
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
   End
   Begin pIconExtractor6.cIconGrid grdIcons 
      Height          =   4215
      Left            =   5460
      TabIndex        =   0
      Top             =   540
      Width           =   2235
      _ExtentX        =   3942
      _ExtentY        =   7435
   End
   Begin MSComctlLib.ImageList ilsIcons32 
      Left            =   780
      Top             =   4920
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   32
      ImageHeight     =   32
      MaskColor       =   12632256
      _Version        =   393216
   End
   Begin VB.Menu mnuFileTOP 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "&Open..."
         Index           =   0
         Shortcut        =   ^O
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save..."
         Enabled         =   0   'False
         Index           =   1
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFile 
         Caption         =   "Save All..."
         Enabled         =   0   'False
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuFile 
         Caption         =   "P&roperties..."
         Enabled         =   0   'False
         Index           =   4
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   5
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   6
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   7
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   8
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   9
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   10
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   11
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   12
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   ""
         Index           =   13
         Visible         =   0   'False
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   14
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Exit"
         Index           =   15
      End
   End
   Begin VB.Menu mnuEditTOP 
      Caption         =   "&Edit"
      Begin VB.Menu mnuEdit 
         Caption         =   "Select &All"
         Enabled         =   0   'False
         Index           =   0
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuEdit 
         Caption         =   "&Invert Selection"
         Enabled         =   0   'False
         Index           =   1
      End
   End
   Begin VB.Menu mnuViewTOP 
      Caption         =   "&View"
      Begin VB.Menu mnuView 
         Caption         =   "&Toolbar"
         Checked         =   -1  'True
         Index           =   0
      End
      Begin VB.Menu mnuView 
         Caption         =   "&Status Bar"
         Checked         =   -1  'True
         Index           =   1
      End
      Begin VB.Menu mnuView 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuView 
         Caption         =   "Lar&ge Icons"
         Checked         =   -1  'True
         Index           =   3
      End
      Begin VB.Menu mnuView 
         Caption         =   "S&mall Icons"
         Index           =   4
      End
      Begin VB.Menu mnuView 
         Caption         =   "&List"
         Index           =   5
      End
      Begin VB.Menu mnuView 
         Caption         =   "&Details"
         Index           =   6
      End
   End
   Begin VB.Menu mnuHelpTOP 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelp 
         Caption         =   "&Icon Explorer Web Page..."
         Index           =   0
         Shortcut        =   {F1}
      End
      Begin VB.Menu mnuHelp 
         Caption         =   "&vbAccelerator on the Web..."
         Index           =   1
      End
      Begin VB.Menu mnuHelp 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuHelp 
         Caption         =   "&About..."
         Index           =   3
      End
   End
   Begin VB.Menu mnuContextTOP 
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuContext 
         Caption         =   "&Save..."
         Enabled         =   0   'False
         Index           =   0
      End
      Begin VB.Menu mnuContext 
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuContext 
         Caption         =   "P&roperties..."
         Enabled         =   0   'False
         Index           =   2
      End
      Begin VB.Menu mnuContext 
         Caption         =   "-"
         Index           =   3
      End
      Begin VB.Menu mnuContext 
         Caption         =   "Select &All"
         Index           =   4
         Visible         =   0   'False
      End
      Begin VB.Menu mnuContext 
         Caption         =   "&Invert Selection"
         Index           =   5
         Visible         =   0   'False
      End
   End
End
Attribute VB_Name = "frmIconEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' 16 December 2002
' SPM
' * Added save all option
' * 32bit (alpha-channel) icons now supported

' 8 February 2000
' SPM
' * Added drag-drop support
' * Added MRU List support
' * Added persistent Open and Save folders

' Current set of icons being browsed:
Private m_cI() As cFileIcon
Private m_iIconCount As Long

' Whether system supports > 16 colour icons or not:
Private m_bTrueColour As Boolean

' Functions/constants for colour depth of system
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal
 nIndex As Long) As Long
Private Const BITSPIXEL = 12
' Functions/constants for making toolbar flat
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd
 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 Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const GW_CHILD = 5
Private Const TBSTYLE_FLAT = &H800

Private m_cMRU As New cMRUFiles
Private m_sInFolder As String
Private m_sOutFolder As String

Private Function ClosestIndex(ByVal lIndex As Long, ByVal lSize As Long) As Long
Dim i As Long
Dim lMinError As Long
Dim lMinErrorIndex As Long
   
   lMinError = 256
   For i = 1 To m_cI(lIndex).ImageCount
      If (m_cI(lIndex).ImageWidth(i) = lSize) Then
         If (m_bTrueColour) Then
            If (m_cI(lIndex).ImageColourCount(i) > 16) Then
               ClosestIndex = i
               Exit Function
            Else
               lMinError = 0
               lMinErrorIndex = i
            End If
         Else
            If (m_cI(lIndex).ImageColourCount(i) > 16) Then
               lMinError = 0
               lMinErrorIndex = i
            Else
               ClosestIndex = i
               Exit Function
            End If
         End If
      ElseIf (Abs(m_cI(lIndex).ImageWidth(i) - lSize) < lMinError) Then
         lMinError = Abs(m_cI(lIndex).ImageWidth(i) - lSize)
         lMinErrorIndex = i
      End If
   Next i
   ClosestIndex = lMinErrorIndex

End Function

Private Sub pOpen()
Dim sFile As String

On Error GoTo ErrorHandler
   
   If VBGetOpenFileName(sFile, , True, , , , "All Icon Files
    (*.EXE;*.DLL;*.ICO)|*.EXE;*.DLL;*.ICO|Icon Files (*.ICO)|*.ICO|Executables
    (*.EXE;*.DLL)|*.EXE;*.DLL|All Files (*.*)|*.*", 1, m_sInFolder, , "ICO",
    Me.hwnd) Then
      pOpenFile sFile
   End If
   
   Exit Sub

ErrorHandler:
   pSetForIcons False
   MsgBox "Error: " & Err.Description, vbExclamation
   m_iIconCount = 0
   Erase m_cI
   pRender
   sbrMain.SimpleText = ""
   Exit Sub
   Resume 0

End Sub

Private Sub pOpenFile(ByVal sFile As String)
Dim lIndex As Long
Dim vItem As Variant
Dim iName As Long
Dim sExt As String
Dim iPos As Long

On Error GoTo ErrorHandler

   m_iIconCount = 0
   grdIcons.Clear
   Erase m_cI
   Set lvwIcons.Icons = Nothing
   Set lvwIcons.SmallIcons = Nothing
   ilsIcons16.ListImages.Clear
   ilsIcons32.ListImages.Clear
   
   sExt = "ICO"
   For iPos = Len(sFile) To 1 Step -1
      If (Mid$(sFile, iPos, 1) = ".") Then
         sExt = UCase$(Mid$(sFile, iPos + 1))
         Exit For
      End If
   Next iPos
   
   If (sExt = "ICO") Then
      sbrMain.Style = sbrSimple
      sbrMain.SimpleText = "Loading icon " & sFile
      m_iIconCount = 1
      ReDim m_cI(1 To 1) As cFileIcon
      Set m_cI(1) = New cFileIcon
      m_cI(1).LoadIcon sFile
      ilsIcons32.ListImages.Add , "C1", m_cI(1).IconPicture(Me.hdc,
       ClosestIndex(1, 32))
      ilsIcons16.ListImages.Add , "C1", m_cI(1).IconPicture(Me.hdc,
       ClosestIndex(1, 16))
      sbrMain.Panels(1).Text = sFile
      m_cMRU.Add sFile
      m_sInFolder = m_cMRU.Folder(1)
      pShowMRU
   Else
      sbrMain.Style = sbrSimple
      sbrMain.SimpleText = "Checking for resources..."
      Dim cR As New cResources
      cR.File = sFile
      cR.GetResourceTypes
      lIndex = cR.IndexOfResourceType(crGroupIcon)
      If (lIndex > 0) Then
         sbrMain.SimpleText = "Getting icon resources..."
         cR.GetResourceNames lIndex
         cR.UnloadModule
         m_iIconCount = cR.ResourceNameCount(lIndex)
         If (m_iIconCount > 0) Then
            ReDim m_cI(1 To m_iIconCount) As cFileIcon
            For iName = 1 To m_iIconCount
               sbrMain.SimpleText = "Loading icon resource " & iName & " of " &
                m_iIconCount & "..."
               Set m_cI(iName) = New cFileIcon
               vItem = cR.ResourceName(lIndex, iName)
               If (VarType(vItem) = vbLong) Then
                  m_cI(iName).LoadIconFromEXE sFile, vItem
               Else
                  m_cI(iName).LoadIconFromEXE sFile, , vItem
               End If
               ilsIcons32.ListImages.Add , "C" & iName,
                m_cI(iName).IconPicture(Me.hdc, ClosestIndex(iName, 32))
               ilsIcons16.ListImages.Add , "C" & iName,
                m_cI(iName).IconPicture(Me.hdc, ClosestIndex(iName, 16))
            Next iName
            sbrMain.Panels(1).Text = sFile
            m_cMRU.Add sFile
            m_sInFolder = m_cMRU.Folder(1)
            pShowMRU
         Else
            MsgBox "No icon resources were found.", vbInformation
            pSetForIcons False
         End If
      Else
         MsgBox "No icons found in file.", vbExclamation
         pSetForIcons False
      End If
   End If
   
   pRender
   
   Exit Sub

ErrorHandler:
   pSetForIcons False
   MsgBox "Error: " & Err.Description, vbExclamation
   m_iIconCount = 0
   Erase m_cI
   pRender
   sbrMain.SimpleText = ""
   Exit Sub
   Resume 0
End Sub
Private Sub pShowMRU()
Dim i As Long

   With m_cMRU
      mnuFile(14).Visible = (.Count > 0)
      For i = 1 To .Count
         mnuFile(5 + i).Visible = True
         If i = 1 Then
            mnuFile(5 + i).Checked = (sbrMain.Panels(1).Text = m_cMRU.Path(i))
         End If
         mnuFile(5 + i).Caption = "&" & i & ") " & m_cMRU.Path(i)
      Next i
      For i = .Count + 1 To 8
         mnuFile(5 + i).Visible = False
      Next i
   End With
End Sub
Private Sub pSetForIcons(Optional ByVal bIcons As Boolean = False)
   mnuFile(1).Enabled = bIcons
   mnuFile(2).Enabled = (bIcons And (m_iIconCount > 1))
   mnuFile(4).Enabled = bIcons
   mnuContext(0).Enabled = bIcons
   mnuContext(2).Enabled = bIcons
   tbrMain.Buttons(2).Enabled = bIcons
   tbrMain.Buttons(4).Enabled = bIcons
   If Not (bIcons) Then
      sbrMain.Style = sbrNormal
      sbrMain.Panels(1).Text = "No icon resources loaded."
      sbrMain.Panels(2).Text = ""
   End If
End Sub
Private Sub pRender()
Dim iIcon As Long
Dim itmX As ListItem
   sbrMain.SimpleText = "Displaying..."
   lvwIcons.ListItems.Clear
   If (m_iIconCount > 0) Then
      lvwIcons.SmallIcons = ilsIcons16
      lvwIcons.Icons = ilsIcons32
      For iIcon = 1 To m_iIconCount
         If IsEmpty(m_cI(iIcon).ResourceID) Then
            Set itmX = lvwIcons.ListItems.Add(, "C" & iIcon,
             m_cI(iIcon).Filename, "C" & iIcon, "C" & iIcon)
         Else
            Set itmX = lvwIcons.ListItems.Add(, "C" & iIcon,
             m_cI(iIcon).ResourceID, "C" & iIcon, "C" & iIcon)
         End If
         itmX.SubItems(1) = m_cI(iIcon).ImageCount
      Next iIcon
      lvwIcons.ListItems(1).Selected = True
      lvwIcons_ItemClick lvwIcons.SelectedItem
   Else
      grdIcons.Clear
      grdIcons.Draw
   End If
   sbrMain.Style = sbrNormal
End Sub

Private Sub pSaveAll()
   
   If (m_iIconCount > 0) Then
      
      ' Get the folder to save to:
      Dim cBF As New cBrowseForFolder
      cBF.hwndOwner = Me.hwnd
      If (m_sOutFolder = "") Then
         cBF.InitialDir = cBF.SpecialFolderLocation(CSIDL_PERSONAL)
      Else
         cBF.InitialDir = m_sOutFolder
      End If
      cBF.EditBox = True
      cBF.FileSystemOnly = True
      cBF.UseNewUI = True
      Dim sFolder As String
      sFolder = Trim(cBF.BrowseForFolder())
      
      If Len(sFolder) > 0 Then
         sbrMain.Style = sbrSimple
         sbrMain.SimpleText = "Saving icons to folder " & sFolder
         
         If (right(sFolder, 1) <> "\") Then
            sFolder = sFolder & "\"
         End If
         ' time to save:
         Dim iItem As Long
         Dim sIconFile As String
         Dim eRes As VbMsgBoxResult
         For iItem = 1 To m_iIconCount
            
            eRes = vbYes
            sIconFile = sFolder & m_cI(iItem).ResourceID & "/home/VB/Utilities/Icon_Extractor/.ico"
            sbrMain.SimpleText = "Saving icon " & iItem & " of " & m_iIconCount
             & " to " & sIconFile
            If (FileExists(sIconFile)) Then
               eRes = MsgBox("File " & sIconFile & " already exists, do you
                want to delete it?", vbYesNoCancel Or vbQuestion)
               If (eRes = vbCancel) Then
                  Exit For
               End If
            End If
            If (eRes = vbYes) Then
               m_cI(iItem).SaveIcon sIconFile
               m_sOutFolder = sFolder
            End If
         Next iItem
         
         sbrMain.Style = sbrNormal
      End If
      
   End If
   
End Sub

Private Sub pSave()
Dim i As Long
Dim bSel() As Boolean
Dim bOneSelected As Boolean
Dim iItem As Long
Dim sFile As String

   If (m_iIconCount > 0) Then
      If Not lvwIcons.SelectedItem Is Nothing Then
         iItem = CLng(Mid$(lvwIcons.SelectedItem.Key, 2))
         
         Debug.Print
         
         ' Evaluate items to save from RHS box:
         ReDim bSel(1 To grdIcons.ItemCount) As Boolean
         For i = 1 To grdIcons.ItemCount
            bSel(i) = grdIcons.Selected(i)
            If (bSel(i)) Then
               bOneSelected = True
            End If
         Next i
         ' If none selected, then assume all to be saved:
         If Not (bOneSelected) Then
            For i = 1 To grdIcons.ItemCount
               bSel(i) = True
            Next i
         End If
      
         ' Now clone the icon:
         Dim cI As New cFileIcon
         m_cI(iItem).CloneTo cI
         
         ' Remove the images which aren't selected:
         For i = cI.ImageCount To 1 Step -1
            If Not (bSel(i)) Then
               cI.RemoveImage i
            End If
         Next i
         
         ' Save the icon:
         Debug.Print
         If (VBGetSaveFileName(sFile, , , "ICO Files (*.ICO)|*.ICO|All Files
          (*.*)|*.*", , m_sOutFolder, , "ICO", Me.hwnd)) Then
            cI.SaveIcon sFile
            m_cMRU.Add sFile
            m_sOutFolder = m_cMRU.Folder(1)
            pShowMRU
         End If
      
      Else
         MsgBox "Please choose an icon to save.", vbInformation
      End If
      
   Else
      MsgBox "No Icon resources to save.", vbInformation
   End If
   
End Sub

Private Sub pProperties()
Dim iItem As Long
Dim iIcon As Long
Dim sMsg As String
   If (m_iIconCount > 0) Then
      If Not lvwIcons.SelectedItem Is Nothing Then
         iItem = CLng(Mid$(lvwIcons.SelectedItem.Key, 2))
         If IsEmpty(m_cI(iItem).ResourceID) Then
            sMsg = "Icon File " & m_cI(iItem).Filename
         Else
            sMsg = "Icon " & m_cI(iItem).ResourceID & " in file " &
             m_cI(iItem).Filename
         End If
         sMsg = sMsg & vbCrLf & vbCrLf & "Icon types within image:" & vbCrLf
         For iIcon = 1 To m_cI(iItem).ImageCount
            sMsg = sMsg & "    " & m_cI(iItem).ImageWidth(iIcon) & " x " &
             m_cI(iItem).ImageHeight(iIcon) & ","
            If (m_cI(iItem).ImageColourCount(iIcon) > 256) Then
               sMsg = sMsg & "millions of"
            Else
               sMsg = sMsg & m_cI(iItem).ImageColourCount(iIcon)
            End If
            sMsg = sMsg & " colours.  Size=" & m_cI(iItem).ImageSize(iIcon) & "
             bytes." & "   " & vbCrLf
         Next iIcon
         MsgBox sMsg, vbInformation
      Else
         MsgBox "Please select an icon to view properties for.", vbInformation
      End If
   Else
      MsgBox "There are no icon resources to view properties for.",
       vbInformation
   End If
End Sub


Private Sub Form_Load()
Dim lColourDepth As Long
Dim lhWnd As Long
Dim lStyle As Long
   
   Dim cR As New cRegistry
   cR.ClassKey = HKEY_CURRENT_USER
   cR.SectionKey = "SOFTWARE\vbAccelerator\IconExtractor"
   If Not m_cMRU.Load(cR) Then
      cR.ClassKey = HKEY_LOCAL_MACHINE
      m_cMRU.Load cR
   End If
   cR.ValueType = REG_SZ
   cR.ValueKey = "InFolder"
   m_sInFolder = cR.Value
   cR.ValueKey = "OutFolder"
   m_sOutFolder = cR.Value
   If m_sInFolder = "" Then m_sInFolder = App.Path
   If m_sOutFolder = "" Then m_sOutFolder = App.Path
   pShowMRU
   
   sbrMain.Panels(1).Text = "No icon resources loaded."
   lColourDepth = GetDeviceCaps(Me.hdc, BITSPIXEL)
   If (lColourDepth > 8) Then
      m_bTrueColour = True
   End If
   lhWnd = GetWindow(tbrMain.hwnd, GW_CHILD)
   If (lhWnd <> 0) Then
      lStyle = GetWindowLong(lhWnd, GWL_STYLE)
      lStyle = lStyle Or TBSTYLE_FLAT
      SetWindowLong lhWnd, GWL_STYLE, lStyle
   End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   Dim cR As New cRegistry
   cR.ClassKey = HKEY_CURRENT_USER
   cR.SectionKey = "SOFTWARE\vbAccelerator\IconExtractor"
   m_cMRU.Save cR
   cR.ValueType = REG_SZ
   cR.ValueKey = "InFolder"
   cR.Value = m_sInFolder
   cR.ValueKey = "OutFolder"
   cR.Value = m_sOutFolder
   cR.ClassKey = HKEY_LOCAL_MACHINE
   m_cMRU.Save cR
   cR.ValueType = REG_SZ
   cR.ValueKey = "InFolder"
   cR.Value = m_sInFolder
   cR.ValueKey = "OutFolder"
   cR.Value = m_sOutFolder

End Sub

Private Sub Form_Resize()
Dim lT As Long
Dim lH As Long
Dim lW As Long
Dim lWI As Long
On Error Resume Next
   lT = 2 * Screen.TwipsPerPixelY - tbrMain.Visible * tbrMain.Height
   lH = Me.ScaleHeight - lT + ((sbrMain.Height + 2 * Screen.TwipsPerPixelY) *
    sbrMain.Visible)
   If (Me.ScaleWidth < (48 + 150) * Screen.TwipsPerPixelX) Then
      lWI = Me.ScaleWidth - 48 * Screen.TwipsPerPixelX
   Else
      lWI = 150 * Screen.TwipsPerPixelX
   End If
   lW = Me.ScaleWidth - lWI - 4 * Screen.TwipsPerPixelX
   lvwIcons.Move 2 * Screen.TwipsPerPixelX, lT, lW, lH
   grdIcons.Move lW + 4 * Screen.TwipsPerPixelX, lT, lWI, lH
End Sub

Private Sub grdIcons_GotFocus()
   mnuEdit(0).Enabled = True
   mnuEdit(1).Enabled = True
End Sub

Private Sub grdIcons_LostFocus()
   mnuEdit(0).Enabled = False
   mnuEdit(1).Enabled = False
End Sub

Private Sub grdIcons_MouseDown(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
Dim i As Long
   If (Button And vbRightButton) = vbRightButton Then
      For i = 3 To 5
         mnuContext(i).Visible = mnuEdit(0).Enabled
      Next i
      PopupMenu mnuContextTOP
   End If
End Sub


Private Sub lvwIcons_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim iItem As Long
   sbrMain.Panels(2).Text = "Icon: " & Item.Text
   pSetForIcons True
   iItem = CLng(Mid$(Item.Key, 2))
   grdIcons.Init m_cI(iItem)
End Sub

Private Sub lvwIcons_MouseDown(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
Dim i As Long
   If (Button And vbRightButton) = vbRightButton Then
      For i = 3 To 5
         mnuContext(i).Visible = mnuEdit(0).Enabled
      Next i
      PopupMenu mnuContextTOP
   End If
End Sub

Private Sub lvwIcons_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As
 Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim sFile As String
Dim sExt As String
   If Data.Files.Count = 1 Then
      sFile = Data.Files(1)
      sExt = UCase$(right$(sFile, 3))
      If sExt = "ICO" Or sExt = "DLL" Or sExt = "EXE" Then
         Effect = vbDropEffectCopy
         pOpenFile sFile
      End If
   End If
End Sub

Private Sub lvwIcons_OLEDragOver(Data As MSComctlLib.DataObject, Effect As
 Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As
 Integer)
Dim sFile As String
Dim sExt As String
   If Data.Files.Count = 1 Then
      sFile = Data.Files(1)
      sExt = UCase$(right$(sFile, 3))
      If sExt = "ICO" Or sExt = "DLL" Or sExt = "EXE" Then
         Effect = vbDropEffectCopy
      End If
   End If
End Sub


Private Sub mnuContext_Click(index As Integer)
   Select Case index
   Case 0
      mnuFile_Click 1
   Case 2
      mnuFile_Click 4
   Case 4
      mnuEdit_Click 0
   Case 5
      mnuEdit_Click 1
   End Select
End Sub

Private Sub mnuEdit_Click(index As Integer)
Dim i As Long
   For i = 1 To grdIcons.ItemCount
      If (index = 0) Then
         grdIcons.Selected(i) = True
      Else
         grdIcons.Selected(i) = Not (grdIcons.Selected(i))
      End If
   Next i
End Sub

Private Sub mnuFile_Click(index As Integer)
   Select Case index
   Case 0
      ' Open:
      pOpen
   Case 1
      ' Save selected:
      pSave
   Case 2
      ' save all
      pSaveAll
   Case 4
      ' Properties of selected:
      pProperties
   Case 6 To 13
      pOpenFile m_cMRU.Path(index - 5)
   Case 15
      Unload Me
   End Select
End Sub

Private Sub mnuHelp_Click(index As Integer)
   Select Case index
   Case 0
      ShellEx "http://vbAccelerator.com/codelib/gfx/iconex.htm"
   Case 1
      ShellEx "http://vbAccelerator.com/index.html"
   Case 3
      ' about
      frmAbout.Show vbModal, Me
   End Select
End Sub

Private Sub mnuView_Click(index As Integer)
Dim i As Long
   Select Case index
   Case 0
      ' toolbar
      mnuView(index).Checked = Not (mnuView(index).Checked)
      tbrMain.Visible = mnuView(index).Checked
      Form_Resize
   Case 1
      ' status bar
      mnuView(index).Checked = Not (mnuView(index).Checked)
      sbrMain.Visible = mnuView(index).Checked
      Form_Resize
   Case 3, 4, 5, 6
      ' view
      For i = 3 To 6
         mnuView(i).Checked = (i = index)
         tbrMain.Buttons(i + 3).Value = Abs(i = index)
      Next i
      lvwIcons.View = index - 3
   End Select
End Sub

Private Sub picIcons_GotFocus()
   grdIcons.GotFocus
   mnuEdit(0).Enabled = True
   mnuEdit(1).Enabled = True
End Sub

Private Sub tbrMain_ButtonClick(ByVal Button As MSComctlLib.Button)
   Select Case Button.Key
   Case "open"
      mnuFile_Click 0
   Case "save"
      mnuFile_Click 1
   Case "properties"
      mnuFile_Click 4
   Case Else
      mnuView_Click Button.index - 3
   End Select
End Sub