Extraer Iconos y
Utilidad para Seleccionar Archivos

Actualizado: 2/Abr/97 (revisado: 06/Jun/2006 nuevo nombre para evitar filtros... ;-) )

Pulsa aqu� para ver la versi�n del 24/Oct/2002
Pulsa aqu� para ver la versi�n del 4/Feb/99

Baja los listados del ejemplo y el ejecutable para 32bits (gs_extraeico.zip 14.3 KB)

Esto que te pongo hoy son dos utilidades en un mismo programa.

El programa en s� sirve para mostrar los iconos incluidos en un archivo exe o dll. Adem�s permite guardar el icono o bitmap.
Incluye un form para seleccionar archivos (la segunda utilidad), el cual muestra los datos del archivo seleccionado, tama�o y fecha/hora de acceso. Si el archivo seleccionado es BMP o ICO, muestra una imagen del mismo.

El tema est� basado en unas funciones del API (como no) para poder mostrar los iconos de un archivo.
El icono seleccionado se muestra en un Picture y �ste es el que se puede guardar.

Al pulsar en el bot�n de Examinar, te permite "navegar" por los discos a los que tengas acceso y poder seleccionar el archivo. Para ello se incluyen usa serie de "filtros" para las extensiones (que puedes modificar en el form de seleccionar archivos).

La forma de llamar al "seleccionador" de archivos est� bastante clara, creo. De todas formas vamos a ver los listados, ya que son bastantes simples y unas "fotos" de los dos forms usados.

Estos links te llevar�n directamente (dentro de �sta p�gina) a la secci�n que prefieras:

El Form gs ExtraeIco.Frm
El Form gs VerFiles.Frm

El Form gs ExtraeIco.frm

'----------------------------------------------
'Extractor/visor de Iconos.
'(c)Guillermo Som, 199?-97
'
'Adaptado para VB4 (16 y 32 bits)   ( 2/Abr/97)
'----------------------------------------------
Option Explicit
Option Compare Text

Dim iNumPicture As Integer
Dim iIconPos As Integer

'Declaraciones para extraer iconos de los programas
#If Win32 Then
    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 GetClassWord Lib "User32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
#Else
    Private Declare Function ExtractIcon Lib "Shell" (ByVal hInstance As Integer, ByVal pszExeName As String, ByVal hIcon As Integer) As Integer
    Private Declare Function GetClassWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
    Private Declare Function DrawIcon Lib "User" (ByVal hdc As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal hIcon As Integer) As Integer
    Private Declare Function BitBlt Lib "Gdi" (ByVal destHdc%, ByVal X%, ByVal Y%, ByVal w%, ByVal h%, ByVal srcHdc%, ByVal srcX%, ByVal srcY%, ByVal Rop As Long) As Integer
#End If
Const GCW_HMODULE = (-16)
'
Const ICON_CELL = 34&
Const SRCCOPY = &HCC0020

Dim iNuevo As Integer


Private Sub CmdAnterior_Click()
    'Leer el icono
    Dim i As Integer
    Dim sProg As String

    If iNuevo Then
        ExtraerLosIconos
        iNuevo = False
    End If
    'Esto es para tener varias imagenes
    'iNumPicture = iNumPicture + 1
    'En principio s�lo hay un Picture
    iNumPicture = 0
    sProg = Trim$(Text1.Text)
    
    iIconPos = iIconPos - 1
    If iIconPos < 0 Then iIconPos = 0

    i = ExtraerIcono(iNumPicture, sProg, iIconPos)
    If i Then
        cmdPrimero.Caption = Str$(iIconPos)
    End If

End Sub


Private Sub CmdGrabar_Click()
    'Grabar la imagen en Picture1
    Dim sTmp As String
    sTmp = InputBox("Escribe el nombre para guardar la imagen", , "*.bmp")
    If Len(sTmp) Then
        If InStr(sTmp, ".bmp") = 0 Then
            'Picture con la extensi�n original
            SavePicture Picture1(0).Picture, sTmp
        Else
            'Image siempre se guarda en BMP
            SavePicture Picture1(0).Image, sTmp
        End If
    End If
End Sub


Private Sub cmdPrimero_Click()
    'Si se pulsa en este Label, se resetea a 0 el contador
    'de la posici�n del icono...
    iIconPos = 0
    CmdSiguiente_Click
End Sub


Private Sub CmdSiguiente_Click()
    'Leer el icono
    Dim i As Integer
    Dim sProg As String

    If iNuevo Then
        ExtraerLosIconos
        iNuevo = False
    End If
    'Esto es para tener varias imagenes
    'iNumPicture = iNumPicture + 1
    'En principio s�lo hay un Picture
    iNumPicture = 0
    sProg = Trim$(Text1.Text)
    
    i = ExtraerIcono(iNumPicture, sProg, iIconPos)
    If i Then
        cmdPrimero.Caption = Str$(iIconPos)
        iIconPos = iIconPos + 1
    Else
        iIconPos = iIconPos - 1
    End If

End Sub


Private Function ExtraerIcono(quePicture As Integer, sPrograma As String, queIcon As Integer) As Integer
    'queIcon    ser� el n�mero de Icono, empezando por cero
    'sPrograma  Es el path del archivo del que queremos extraer el icono
    
    
#If Win32 Then
    'En 32 bits son Long
    Dim myhInst As Long
    Dim hIcon As Long
    Dim i As Long
#Else
    'En 16 bits son Integer
    Dim myhInst As Integer
    Dim hIcon As Integer
    Dim i As Integer
#End If

    myhInst = GetClassWord(hWnd, GCW_HMODULE)
    hIcon = ExtractIcon(myhInst, sPrograma, queIcon)
    If hIcon Then
        Picture1(quePicture).Picture = LoadPicture("")
        Picture1(quePicture).AutoRedraw = -1
        i = DrawIcon(Picture1(quePicture).hdc, 0, 0, hIcon)
        Picture1(quePicture).Refresh
    End If
    ExtraerIcono = hIcon
End Function


Private Sub ExtraerLosIconos()
    'Leer todos los iconos
    
    Dim R
    Dim X As Integer
    Dim nIconos As Integer
    Dim sProg As String
    Dim i As Integer

    'Por si queremos tener m�s Picture de Iconos
    'aunque en este programa s�lo hay una
    iNumPicture = 0
    Picture1(iNumPicture).Visible = False
    Picture1(iNumPicture).AutoRedraw = True
    '
    X = 0
    
    sProg = Trim$(Text1.Text)   'Archivo a procesar
    iIconPos = 0                'Empezar por el primero
    Do
        i = ExtraerIcono(iNumPicture, sProg, iIconPos)
        If i Then
            iIconPos = iIconPos + 1
        Else
            Exit Do
        End If
    Loop
    nIconos = iIconPos - 1
    Picture2.Cls
    For X = 0 To nIconos
        i = ExtraerIcono(iNumPicture, sProg, X)
        If i Then
            R = BitBlt(Picture2.hdc, 2 + X * ICON_CELL, 0, 32, 32, Picture1(iNumPicture).hdc, 0, 0, SRCCOPY)
        End If
    Next
    Picture1(iNumPicture).Visible = True
    Picture1(iNumPicture).AutoRedraw = False

    iIconPos = 0
End Sub


Private Sub Form_Load()
    'Para leer los dibujos en Picture2
    iNuevo = True
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Set ExtraerIcon = Nothing
    End
End Sub


Private Sub cmdExaminar_Click()
    Dim i As Integer
    Dim sTmp As String
    Dim fExt As String

    sTmp = Trim$(Text1.Text)
    With gsVerFiles
        .Text2.Text = sTmp
        
        fExt = ".exe"
        i = InStr(sTmp, ".")
        If i Then
            fExt = Mid$(sTmp, i)
            sTmp = Left$(sTmp, i - 1)
        End If
        If Right$(sTmp, 1) = "\" Then
            i = Len(sTmp)
            sTmp = Left$(sTmp, i - 1)
        Else
            For i = Len(sTmp) To 1 Step -1
                If Mid$(sTmp, i, 1) = "\" Then
                    sTmp = Left$(sTmp, i - 1)
                    Exit For
                End If
            Next
        End If
        'Asignar la extensi�n...
        .Combo1.Text = "*" & fExt
        'Asignar el directorio...
        If Len(sTmp) = 0 Then
            sTmp = CurDir$
        End If
        .Drive1 = sTmp
        .Dir1.Path = sTmp
        .Show vbModal
        If .Text2 <> "Cancelar" Then
            Text1.Text = .Text2
            iIconPos = 0
            iNuevo = True
        End If
    End With
    Unload gsVerFiles
End Sub

El Form gsVerFiles.frm

'----------------------------------------------------------------
'Utilidad para seleccionar archivos
'Si es un archivo Ico o Bmp, se muestra la imagen
'
'(c)Guillermo Som, 199?-97
'----------------------------------------------------------------
Option Explicit
Const ANCHOMENU = 360 * 3

#If Win32 Then
    Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, lParam As Any) As Long
#Else
    Private Declare Function SendMessage Lib "User" _
        (ByVal hWnd As Integer, ByVal wMsg As Integer, _
         ByVal wParam As Integer, lParam As Any) As Long
#End If

Const CB_FINDSTRINGEXACT = &H158    'Buscar cadena completa en un ComboBox
Const CB_FINDSTRING = &H14C         'Buscar cadena desde el principio en un ComboBox
Const LB_FINDSTRINGEXACT = &H1A2    'Idem en ListBox
Const LB_FINDSTRING = &H18F         '


Private Sub Combo1_Change()
    'Para que esta ventana sirva para varias cosas,
    'se tendr� en cuenta el contenido de Text1.Text
    'al cargar, para ver que se muestra.

    Dim sTmp As String
    Dim i As Integer
    
    sTmp = Trim$(Combo1.Text)
    
    'Si est� lo escrito, seleccionar ese item
    BuscarEnCombo sTmp, Combo1
    'Seleccionar el tipo de archivo a mostrar  (30/Oct/93)
    File1.Pattern = Combo1.Text
    
    If File1.ListCount Then
        File1.ListIndex = 0
    End If
    File1_Click
End Sub


Private Sub Command1_Click()
    'Aceptar
    'Asignar la imagen
    Hide
End Sub


Private Sub Command2_Click()
    'Cancelar
    Text2.Text = "Cancelar"
    Hide
End Sub


Private Sub Dir1_Change()
    'Cambiar de directorio                     (30/Oct/93)
    File1.Path = Dir1.Path
    File1_Click
End Sub


Private Sub Drive1_Change()
    'Cambiar la unidad de disco                (30/Oct/93)
    On Error GoTo ErrorDeDisco
    Dir1.Path = Drive1.Drive
    File1_Click
    Exit Sub
ErrorDeDisco:
    Drive1.Drive = Dir1.Path
    Exit Sub

End Sub


Private Sub File1_Click()
    Dim sTmp As Variant

    sTmp = Trim$(Dir1.Path) & "\"
    If Right$(sTmp, 2) = "\\" Then
        sTmp = Left$(sTmp, Len(sTmp) - 1)
    End If
    Text2.Text = sTmp & File1.filename
    sTmp = ""
    
    On Local Error Resume Next
    sTmp = FileDateTime(Text2.Text)
    LblFileInfo(0).Caption = Format(sTmp, "ddddd, hh:mm  ")
    LblFileInfo(1).Caption = Format(FileLen(Text2.Text), "###,###  ")
    
    Image1.Picture = LoadPicture(Text2.Text)
    If Err Then
        Err = 0
        Image1.Picture = LoadPicture()
    End If
    On Local Error GoTo 0
End Sub


Private Sub Form_Activate()
    Combo1.SetFocus
End Sub


Private Sub Form_Load()
    
    'Asignar las extensiones
    Combo1.AddItem "*.*"    '0
    'Extensiones para imagenes
    Combo1.AddItem "*.ico"
    Combo1.AddItem "*.bmp"
    Combo1.AddItem "*.wmf"
    Combo1.AddItem "*.dib"
    Combo1.AddItem "*.gif"
    Combo1.AddItem "*.jpg"
    Combo1.AddItem "*.pcx"
    'Extensiones de textos
    Combo1.AddItem "*.txt"
    Combo1.AddItem "*.doc"
    Combo1.AddItem "*.wri"
    Combo1.AddItem "*.diz"
    Combo1.AddItem "*.ini"
    'extensiones para lenguajes
    Combo1.AddItem "*.bas"
    Combo1.AddItem "*.vbp"
    Combo1.AddItem "*.vbg"
    Combo1.AddItem "*.mak"
    Combo1.AddItem "*.frm"
    Combo1.AddItem "*.c*"
    Combo1.AddItem "*.h*"
    Combo1.AddItem "*.pas"
    'extensiones para programas y librer�as
    Combo1.AddItem "*.exe"
    Combo1.AddItem "*.dll"
    Combo1.AddItem "*.res"

    Dim sTmp As String

    sTmp = Trim$(Dir1.Path) & "\"
    If Right$(sTmp, 2) = "\\" Then
        sTmp = Left$(sTmp, Len(sTmp) - 1)
    End If
    Text2.Text = sTmp & File1.filename

End Sub


Private Sub Form_Unload(Cancel As Integer)
    Set gsVerFiles = Nothing
End Sub


Private Sub BuscarEnCombo(sTexto As String, cList As Control)
    'Esta funci�n comprobar� si el texto indicado existe en la lista
    'El valor devuelto, ser� la posici�n dentro de la lista � -1 si hay "fallos"
    '
    'Para buscar en el List/combo usaremos una llamada al API
    '(si ya hay una forma de hacerlo, �para que re-hacerla?)
    '
    Dim L As Long
    
    If cList.ListCount = 0 Then
        'Seguro que no est�
    Else
        'Si el control es un Combo
        If TypeOf cList Is ComboBox Then
            L = SendMessage(cList.hWnd, CB_FINDSTRING, -1, ByVal sTexto)
        Else
            'no es un Combo, salir
            Exit Sub
        End If
    End If
End Sub

Extraer Iconos y Utilidad para Seleccionar Archivos

Actualizado: 2/Abr/97 (revisado: 06/Jun/2006 nuevo nombre para evitar filtros... ;-) )

Extraer Iconos y
Utilidad para Seleccionar Archivos