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:
- 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