gs_ExtraeIco versión 3

Utilidad para ver y extraer iconos de ejecutables y librerías de Windows

 

Publicado el 4/Feb/99
Revisado el 4/Feb/99 (revisado: 06/Jun/2006 nuevo nombre para evitar filtros... ;-) )

Pulsa aquí para ver la versión del 24/Oct/2002


Aquí tienes una nueva versión de esta utilidad que sirve para ver y extraer (y guardar) los iconos incluidos en los ejecutables y librerías de Windows (sólo para 32 bits)

Entre las novedades que tiene esta versión con respecto a la versión anterior:

En el código de esta nueva versión podrás encontrar algunas cosillas interesantes, como calcular el icono en el que está el cursor al pasar el ratón por encima del picture que los contiene.
Usar un botón para mostrar y ocultar el panel en el que están todos los iconos y, aunque no está operativo, poder hacer zoom al desplegar/contraer el panel; aunque no lo he dejado ya que el efecto no me acabó de agradar.
También encontarás el código para hacer scroll virtual, es decir mostrar sólo una parte de una imagen y poder mostrar el resto usando los scrollbars que hay a la derecha y abajo.

Espero que lo encuentres útil y que te sirva el código, que al fin y al cabo eso es lo verdaderamente útil.

Aquí tienes una captura del programa en ejecución y parte del listado, el resto lo puedes ver en el zip que se acompaña.

gsExtraeIco v3

Pulsa aquí para descargar el zip con los listados y el ejecutable para el VB5 SP3 (gs_ExtraeIcoV3.zip 26.9 KB)


El código:

'
'----------------------------------------------------------------------------------
'Extractor/visor de Iconos.
'
'Adaptado para VB4 (16 y 32 bits)   ( 2/Abr/97)
'Versión 3.xx.xx    (22-23/Ene/99)
'                   Sólo para 32 bits con scroll virtual
'                   Usando la rutina de Eduardo Morcillo para guardar como ICO
'                   (antes sólo se guardaba como BMP)
'        3.01.07    (03/Feb/99)
'
'©Guillermo 'guille' Som, 1993-99
'----------------------------------------------------------------------------------
Option Explicit
Option Compare Text

Private EfectoZoom As Boolean
Private MostrarPicIconos As Boolean

Private nIconos As Long
Private IconoActual As Long

Private difSW As Long
Private difSH As Long

Dim NumPicture As Long
Dim IconPos As Long
Dim bNuevo As Boolean

' Declaraciones para extraer iconos de los programas
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

Const GCW_HMODULE = (-16)
'
Const ICON_CELL = 34&
Const SRCCOPY = &HCC0020

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

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

    i = ExtraerIcono(NumPicture, sProg, IconPos)
    If i Then
        cmdPrimero.Caption = Str$(IconPos)
        PosicionarShape
    End If
End Sub

Private Sub CmdGrabar_Click()
    ' Grabar la imagen en Picture1
    Dim i As Long
    Dim sTmp As String
    Dim fExt As String
    Dim sFic As String
    
    ' Preguntar el nombre del fichero con el que se guardará la imagen
    sTmp = "Icono" & IconPos & ".ico"
    sFic = sTmp
    With gsVerFiles
        .Text2.Text = sTmp
        .Extensiones "*.ico|*.bmp|*.*"
        fExt = ".ico"
        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$
        Else
            If InStr(sTmp, "\") = 0 Then
                sTmp = CurDir$
            End If
        End If
        .Drive1 = sTmp
        .Dir1.Path = sTmp
        ' Mostrar el nombre inicial, ya que sino lo que hace es mostrar el nombre
        ' del primer fichero que encuentre con la extensión indicada
        .Text2.Text = sFic
        .Show vbModal
        If .Text2 <> "Cancelar" Then
            sTmp = .Text2
        Else
            sTmp = ""
        End If
    End With
    Unload gsVerFiles
    
    '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 cmdMas_Click()
    Dim minTop As Long
    Dim i As Long
    
    If nIconos > -1 Then
        minTop = cmdMas.Top + cmdMas.Height + 60
        
        ' Mostrar el bitmap con los iconos u ocultarlo
        MostrarPicIconos = Not MostrarPicIconos
        picScroll1.Visible = MostrarPicIconos
        '
        'EfectoZoom = True
        If MostrarPicIconos Then
            cmdMas.Caption = "«"
        '    For i = Height To picScroll2.Height + HScroll1.Height - difSH + minTop Step 120
        '        Height = i
        '    Next
        Else
            cmdMas.Caption = "»"
        '    For i = Height To minTop + 360 Step -120
        '        Height = i
        '    Next
        End If
        'EfectoZoom = False
        '
        VScroll1.Visible = MostrarPicIconos
        HScroll1.Visible = MostrarPicIconos
        Form_Resize
        '
    End If
    cmdPrimero.SetFocus
End Sub

Private Sub cmdPrimero_Click()
    ' Si se pulsa en este Label, se resetea a 0 el contador
    ' de la posición del icono...
    IconPos = -1
    IconoActual = 0
    CmdSiguiente_Click
    Shape1.Visible = True
End Sub

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

    If bNuevo Then
        ExtraerLosIconos
        bNuevo = False
    End If
    ' Esto es para tener varias imagenes
    ' NumPicture = NumPicture + 1
    ' En principio sólo hay un Picture
    NumPicture = 0
    sProg = Trim$(Text1.Text)
    
    IconPos = IconPos + 1
    i = ExtraerIcono(NumPicture, sProg, IconPos)
    If i Then
        cmdPrimero.Caption = Str$(IconPos)
        PosicionarShape
    End If
End Sub

Private Function ExtraerIcono(quePicture As Long, sPrograma As String, queIcon As Long) As Long
    ' queIcon    será el número de Icono, empezando por cero
    ' sPrograma  Es el path del archivo del que queremos extraer el icono
    
    
    ' En 32 bits son Long
    Dim myhInst As Long
    Dim hIcon As Long
    Dim i As Long

    myhInst = GetClassWord(hWnd, GCW_HMODULE)
    hIcon = ExtractIcon(myhInst, sPrograma, queIcon)
    If hIcon Then
        With Picture1(quePicture)
            .Picture = LoadPicture("")
            .AutoRedraw = -1
            i = DrawIcon(.hDC, 0, 0, hIcon)
            ' Convertir la imagen en formato ICO                        (22/Ene/99)
            Set .Picture = BMPToIcon(.Image)
            .Refresh
        End With
    End If
    ExtraerIcono = hIcon
End Function

Private Sub ExtraerLosIconos()
    ' Leer todos los iconos
    
    Dim n As Long
    Dim sProg As String
    Dim i As Long
    Dim x1 As Long
    Dim y1 As Long
    Dim nColumnas As Long
    Dim nTwips As Long
    
    ' Averiguar el número de columnas
    nColumnas = picScroll2.ScaleWidth \ ICON_CELL
    nTwips = Screen.TwipsPerPixelY
    
    ' Por si queremos tener más Picture de Iconos
    ' aunque en este programa sólo hay una
    NumPicture = 0
    Picture1(NumPicture).Visible = False
    Picture1(NumPicture).AutoRedraw = True
    '
    ' Contar el número de iconos que tiene el fichero indicado
    sProg = Trim$(Text1.Text)   ' Archivo a procesar
    IconPos = 0                 ' Empezar por el primero
    Do
        i = ExtraerIcono(NumPicture, sProg, IconPos)
        If i Then
            IconPos = IconPos + 1
        Else
            Exit Do
        End If
    Loop
    nIconos = IconPos - 1
    picScroll2.Cls
    ' Ajustar el tamaño del picScroll2
    picScroll2.Height = (nIconos \ nColumnas + 1) * (ICON_CELL * nTwips) + 2 * nTwips
    picScroll2.Width = nColumnas * (ICON_CELL * nTwips) + 4 * nTwips
    '
    For n = 0 To nIconos
        i = ExtraerIcono(NumPicture, sProg, n)
        If i Then
            'R = BitBlt(picScroll2.hDC, 2 + x * ICON_CELL, 0, 32, 32, Picture1(NumPicture).hDC, 0, 0, SRCCOPY)
            ' Mostrarlos según el número de columnas
            y1 = 2 + (n \ nColumnas) * ICON_CELL
            x1 = 2 + (n Mod nColumnas) * ICON_CELL
            Call BitBlt(picScroll2.hDC, x1, y1, 32, 32, Picture1(NumPicture).hDC, 0, 0, SRCCOPY)
        End If
    Next
    Picture1(NumPicture).Visible = True
    Picture1(NumPicture).AutoRedraw = False
    ' Ajustar los controles
    'Form_Resize
    If nIconos > -1 Then
        CmdGrabar.Enabled = True
        CmdAnterior.Enabled = True
        CmdSiguiente.Enabled = True
        cmdMas.Enabled = True
        ' Mostrar el picScroll
        MostrarPicIconos = False
        cmdMas_Click
        picScroll2.ToolTipText = " Haz DobleClick para mostrar este icono "
    Else
        CmdGrabar.Enabled = False
        CmdAnterior.Enabled = False
        CmdSiguiente.Enabled = False
        ' Ocultar el PicScroll
        nIconos = 0
        MostrarPicIconos = True
        cmdMas_Click
        cmdMas.Enabled = False
        ' Borrar la imagen
        'Set Picture1(NumPicture).Picture = LoadPicture
        cmdPrimero.Caption = ""
        nIconos = -1
    End If
    
    IconPos = -1
End Sub

Private Sub Form_Load()
    Dim sTmp As String
    
    sTmp = App.Title & " v" & App.Major & _
           " ©Guillermo 'guille' Som, 1993-"
    If Year(Now) > 1999 Then
        sTmp = sTmp & Year(Now)
    Else
        sTmp = sTmp & "1999"
    End If
    Caption = sTmp
    
    
    ' Para leer los dibujos en picScroll2
    bNuevo = True
    
    nIconos = -1
    
    Shape1.Visible = False
    picScroll1.Visible = False
    VScroll1.Visible = False
    HScroll1.Visible = False
    '
    CmdGrabar.Enabled = False
    CmdAnterior.Enabled = False
    CmdSiguiente.Enabled = False
    cmdMas.Enabled = False
    
    ' Para el cálculo de la posición de cada icono, es necesario usar vbPixels
    picScroll2.ScaleMode = vbPixels
    '
    '---Inicio de los controles de scroll virtual---
    '----------------------------------------------------------
    'El contenedor virtual (picScroll1)
    '   será el contenedor de:
    'El contenedor visual (picScroll2)
    '   que a su vez contendrá los controles 'visuales' de
    '   nuestro formulario
    '----------------------------------------------------------
    '
    'Es importante que el tamaño del picScroll2 sea el tamaño
    'máximo que queramos que tenga el formulario
    '
    'El contenedor visual debe estar contenido en el virtual
    Set picScroll2.Container = picScroll1
    
    'Diferencia entre el ScaleWidth con el Width
    difSW = ScaleWidth - Width
    'Diferencia entre el ScaleHeight con el Height
    difSH = ScaleHeight - Height
    
    'Para que no se vea diferente el picScroll1
    'en el entorno lo dejo en blanco para que se diferencie
    picScroll1.BackColor = picScroll2.BackColor
    
    'Asegurarnos de que no tienen bordes
    picScroll1.BorderStyle = vbBSNone
    picScroll2.BorderStyle = vbBSNone
    
    HScroll1.Left = 0
    VScroll1.Top = 0
    VScroll1.SmallChange = 120 '10 en Pixels
    VScroll1.LargeChange = 360 '60 en Pixels
    HScroll1.SmallChange = 120
    HScroll1.LargeChange = 360
    '
    '---Fin de las asignaciones para el Scroll virtual---

End Sub

Private Sub Form_Resize()
    Dim minTop As Long
    
    On Local Error Resume Next
    
    If WindowState <> vbMinimized Then
        If Width < 2880 Then Width = 2880
        
        'minTop = CmdSiguiente.Top + CmdSiguiente.Height + 90
        'minTop = Line3DEx1.Top + 45
        minTop = cmdMas.Top + cmdMas.Height + 60
        If MostrarPicIconos Then
            If ScaleWidth - VScroll1.Width > 0 And ScaleHeight - HScroll1.Height > 0 Then
                ' Initialize location of both pictures.
                picScroll1.Move 0, minTop, _
                                ScaleWidth - VScroll1.Width, _
                                ScaleHeight - HScroll1.Height - minTop
                If Err Then
                    Height = picScroll2.Height + HScroll1.Height - difSH + minTop
                    picScroll1.Move 0, minTop, _
                                    ScaleWidth - VScroll1.Width, _
                                    ScaleHeight - HScroll1.Height - minTop
                End If
                
                picScroll2.Move 0, 0
            End If
            
            ' Sólo ajustar al tamaño del PicScroll si no se está haciendo Zoom
            If Not EfectoZoom Then
                ' Si el tamaño es mayor que el contenido...
                If Width - difSW > picScroll2.Width + VScroll1.Width Then
                    Width = picScroll2.Width + VScroll1.Width - difSW
                End If
                ' igual con el alto...
                If Height - difSH > picScroll2.Height + HScroll1.Height + minTop Then
                    Height = picScroll2.Height + HScroll1.Height - difSH + minTop
                End If
                
                ' Position the horizontal scroll bar.
                HScroll1.Top = picScroll1.Height + minTop
                HScroll1.Width = picScroll1.Width
                ' Position the vertical scroll bar.
                VScroll1.Top = minTop
                VScroll1.Left = picScroll1.Width
                VScroll1.Height = picScroll1.Height
                ' Set the Max value for the scroll bars.
                HScroll1.Max = picScroll2.Width - picScroll1.Width
                VScroll1.Max = picScroll2.Height - picScroll1.Height
                ' Determine if child picture will fill up
                ' screen. If so, then there is no need to
                ' use scroll bars.
                VScroll1.Enabled = (picScroll1.Height < picScroll2.Height)
                HScroll1.Enabled = (picScroll1.Width < picScroll2.Width)
            End If
        Else
            Height = minTop + 360
            If Not EfectoZoom Then
                ' Si el tamaño es mayor que el contenido...
                If Width - difSW > picScroll2.Width + VScroll1.Width Then
                    Width = picScroll2.Width + VScroll1.Width - difSW
                End If
            End If
        End If
    End If
    
    Err = 0
    On Local Error GoTo 0
End Sub

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

End Sub

Private Sub cmdExaminar_Click()
    Dim i As Long
    Dim sTmp As String
    Dim fExt As String
    Dim sFic As String

    sTmp = Trim$(Text1.Text)
    sFic = sTmp
    With gsVerFiles
        .Text2.Text = sTmp
        .Extensiones "*.exe|*.dll|*.*"
        
        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$
        Else
            If InStr(sTmp, "\") = 0 Then
                sTmp = CurDir$
            End If
        End If
        .Drive1 = sTmp
        .Dir1.Path = sTmp
        .Text2.Text = sFic
        .Show vbModal
        If .Text2 <> "Cancelar" Then
            Text1.Text = .Text2
            IconPos = 0
            bNuevo = True
        End If
    End With
    Unload gsVerFiles
    
    ' Mostrar el form normal y ocultar el de selección de ficheros
    'Refresh
    DoEvents
    ' Mostrar los iconos del fichero seleccionado
    If Len(Text1.Text) Then
        cmdPrimero_Click
    End If
End Sub

Private Sub HScroll1_Change()
    ' picScroll2.Left is set to the negative
    ' of the value because as you scroll the
    ' scroll bar to the right, the display
    ' should move to the Left, showing more
    ' of the right of the display, and vice-
    ' versa when scrolling to the left.
    picScroll2.Left = -HScroll1.Value
End Sub

Private Sub picScroll2_DblClick()
    ' Mostrar el icono en el que se ha hecho DobleClick
    IconPos = IconoActual - 1
    CmdSiguiente_Click
End Sub

Private Sub VScroll1_Change()
    ' picScroll2.Top is set to the negative of
    ' the value because as you scroll the
    ' scroll bar down, the display should
    ' move up, showing more of the bottom of
    ' the display, and vice-versa when
    ' scrolling up.
    picScroll2.Top = -VScroll1.Value
End Sub

Private Sub picScroll2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Calcular la posición y mostrar el Shape1 en esa posición
    Dim x1 As Long
    Dim y1 As Long
    Dim n As Long
    Dim nColumnas As Long
    
    nColumnas = picScroll2.ScaleWidth \ ICON_CELL
    
    n = y \ ICON_CELL
    y1 = n * ICON_CELL + 2
    
    n = x \ ICON_CELL
    x1 = n * ICON_CELL + 2
    
    IconoActual = (y1 \ ICON_CELL) * nColumnas + (x1 \ ICON_CELL)
    
    ' Sólo mover el Shape si está dentro del número de iconos
    If IconoActual <= nIconos Then
        Shape1.Left = x1
        Shape1.Top = y1
    End If
End Sub

Private Sub PosicionarShape()
    Dim x1 As Long
    Dim y1 As Long
    Dim nColumnas As Long
    
    ' Averiguar el número de columnas
    nColumnas = picScroll2.ScaleWidth \ ICON_CELL
    
    y1 = 2 + (IconPos \ nColumnas) * ICON_CELL
    x1 = 2 + (IconPos Mod nColumnas) * ICON_CELL
    
    Shape1.Left = x1
    Shape1.Top = y1
End Sub