Visual Basic Programming Code Examples Visual Basic > Files Directories Drives Code Examples Get icons from exe-dll files Get icons from exe-dll files VERSION 4.00 Begin VB.Form Form1 Appearance = 0 'Flat BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Icon Extract" ClientHeight = 2355 ClientLeft = 2580 ClientTop = 2295 ClientWidth = 4170 BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 2760 Icon = "ICONEXTR.frx":0000 Left = 2520 LinkMode = 1 'Source LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 2355 ScaleWidth = 4170 top = 1950 Width = 4290 begin VB.CommandButton btnSave Caption = "&Save" Height = 375 Left = 3000 TabIndex = 8 top = 600 Width = 1095 End begin VB.PictureBox pic2 Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H80000005& ForeColor = &H80000008& Height = 492 Left = 2280 ScaleHeight = 465 ScaleWidth = 465 TabIndex = 2 top = 1800 Width = 492 End begin VB.CommandButton btnCopy Appearance = 0 'Flat BackColor = &H80000005& Caption = "Copy to picture box ->" Height = 372 Left = 120 TabIndex = 6 top = 1800 Width = 2052 End begin VB.HScrollBar hs Enabled = 0 'False Height = 252 Left = 600 TabIndex = 1 top = 1440 Width = 1212 End begin VB.CommandButton btnExit Appearance = 0 'Flat BackColor = &H80000005& Caption = "&Exit" Height = 372 Left = 3000 TabIndex = 7 top = 1080 Width = 1092 End begin VB.PictureBox pic Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H80000005& ForeColor = &H80000008& Height = 492 Left = 960 ScaleHeight = 465 ScaleWidth = 465 TabIndex = 0 top = 840 Width = 492 End begin VB.CommandButton btnOpen Appearance = 0 'Flat BackColor = &H80000005& Caption = "&Open" Height = 372 Left = 3000 TabIndex = 3 top = 120 Width = 1092 End begin VB.Label lblNumIcons Appearance = 0 'Flat BackColor = &H00C0C0C0& ForeColor = &H80000008& Height = 252 Left = 1320 TabIndex = 5 top = 240 Width = 612 End begin VB.Label lblDumb Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Number of Icons in file:" ForeColor = &H80000008& Height = 492 Left = 120 TabIndex = 4 top = 120 Width = 1092 End End Attribute VB_Name = "Form1" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim iconn% Dim iconfilename$ Dim numicons% Dim windir$ Dim hModule& Dim iconmod$ Dim Iconh& Dim X& Private Declare Function DrawIcon Lib "user32" (ByVal hdc as Long, ByVal X as Long, ByVal Y as Long, ByVal hIcon as Long) as Long Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst as Long, ByVal lpszExeFileName as String, ByVal nIconIndex as Long) as Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName as String) as Long Private sub btnCopy_Click() pic2.Picture = pic.Image 'Must be pic2.Picture = pic.IMAGE, not pic.Picture, because it is not 'actually part of the picture yet when you use the API call End Sub Private sub btnExit_Click() Unload Form1 End Sub Private sub btnOpen_Click() iconfilename$ = InputBox$("Icon File(.ICO,.EXE,.DLL):", "Icon Extract", App.Path & "\" & App.EXEName & ".exe") If iconfilename$ = "" Then Exit Sub pic.Cls 'clears the picture box iconmod$ = iconfilename$ + Chr$(0) 'prepares filename Iconh = ExtractIcon(hModule, iconmod$, -1) 'gets number of icons numicons% = Iconh 'puts it into a variable lblNumIcons.Caption = Str$(numicons%) 'shows number of icons on label numicons% = numicons% - 1 'Accounts for the first icon, at number 0 If numicons% > 1 Then 'disables scroll bar if only one or less hs.Enabled = -1 Else hs.Enabled = 0 end If Iconh = ExtractIcon(hModule, iconmod$, 0) 'Extracts the first icon X& = DrawIcon(pic.hdc, 0, 0, Iconh) 'Draws the first icon hs.Max = numicons% 'sets maximum scroll bar value to the number of icons hs.Value = 0 End Sub Private sub btnSave_Click() dim answer On Error GoTo handling_err If pic2.Image = "" Then Exit Sub answer = InputBox("What's the name of the icon to be saved?", , App.Path & "\test.ico") If answer = "" Then Exit Sub SavePicture pic2, answer Exit Sub handling_err: If Err = 3 Then Exit Sub End Sub Private sub Form_Unload(Cancel as Integer) End End Sub Private sub hs_Change() pic.Cls 'Clears the picture box iconn% = hs.Value 'sets the value of the icon number to the scroll bar position iconmod$ = iconfilename$ + Chr$(0) 'prepares filename for ExtractIcon Iconh = ExtractIcon(hModule, iconmod$, iconn%) 'Extracts the specified icon X& = DrawIcon(pic.hdc, 0, 0, Iconh) 'Draws icon End Sub Return