VB5 Icon Extractor Source Code (101K)
VB5 Icon Extractor (48K)
VB6 Icon Extractor Source Code (97K)
VB6 Icon Extractor (44K)
19 Dec 2002
Icons with Alpha channel (32 bit ARGB) now supported.
Facility to save all icons from the selected executable or DLL at the same time added.
XP Visual Styles now supported.
Subclassing Without The Crashes
IShellFolder Extended Type Library Version 1.2 (ISHF_Ex.Tlb)
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 & ".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
