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