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:
- Se puede guardar el icono en formato ICO, antes sólo se hacía en formato BMP, esto es posible gracias al código de Eduardo Morcillo, que puedes verlo en las colaboraciones.
- Se muestran todos los iconos en un panel desplazable, antes sólo se mostraban unos cuantos.
- De ese panel se puede seleccionar el icono que se quiera, simplemente haciendo doble-click en uno de los iconos.
- El panel se puede ocultar.
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.
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
