Pulsa aqu� para ver la versi�n del 24/Oct/2002
Pulsa aqu� para ver la versi�n del 4/Feb/99Baja 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
'---------------------------------------------- '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