gs_ExtraeIco versión 3.02.2300

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

 

Publicado el 24/Oct/2002
Actualizado el 24/Oct/2002 (revisado: 06/Jun/2006 nuevo nombre para evitar filtros... ;-) )

Links a las versiones anteriores: la de Abril 97, la de Feb 99


Esta es una nueva versión de la utilidad para extraer iconos de los ejecutables y librerías de Windows.
Las cosillas que he cambiado desde la última versión de Febrero de 1999, son las siguientes:



Espero que esta nueva "reencarnación" de la utilidad te siga siendo tan útil o más que las versiones anteriores, esa es siempre la intención cuando se hace una nueva versión... y para que puedas modificarla a tu gusto, como es costumbre, adjunto el código de la utilidad, así como el fichero de recursos.
Decirte que en esta versión, el ejecutable está compilado con Visual Basic 6.0 y el Service Pack 5 (SP5).


Aquí tienes una captura del programa en ejecución y la ventana que se utiliza tanto para indicar el nombre del icono en el que se guardará el que hayas seleccionado, como para seleccionar la librería o el ejecutable del que quieres ver los iconos.


El programa en ejecución

 


La opción de seleccionar ficheros

 

Pulsa aquí para descargar el zip con los listados y el ejecutable para el VB6 SP5 (gs_ExtraeIcoV32.zip 47.5 KB)

A continuación está el código completo de:
el formulario principal,
el de seleccionar ficheros,
el código para convertir bitmaps en iconos, de Eduardo Morcillo y
el código del control para simular líneas 3D.

Este código está "coloreado" usando la utilidad gsHTMCodeColor


El código del formulario principal:


'------------------------------------------------------------------------------
' 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/1999)
'        3.01.7100  (07/Jul/2000)   Probado en Windows 2000
'        3.01.7200  (26/Feb/2001)   Permite que se suelte el fichero a examinar
'        3.02.1xxx  (06/Sep/2002)   Averiguar el directorio System y otras pruebas
'                                   Permitir asignar el número de columnas
'        3.02.2xxx  (24/Oct/2002)   Al guardar, recordar el último directorio
'                        ""         Nuevo icono de 256 colores para el ejecutable
'            .21xx       ""         Permite usar los temas de Windows XP
'            .22xx       ""         Permite indicar un fichero en la línea de comandos
'            .23xx       ""         Añado un fichero de recursos con varios iconos
'
' ©Guillermo 'guille' Som, 1993-2002
'------------------------------------------------------------------------------
Option Explicit
Option Compare Text

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
'
Private nTwips As Long
Private mColumnas As Long
Private EfectoZoom As Boolean
Private MostrarPicIconos As Boolean

Private nIconos As Long
Private IconoActual As Long

Private difSW As Long
Private difSH As Long

Private NumPicture As Long
Private IconPos As Long
Private bNuevo As Boolean

' Para averiguar el directorio System
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
    (ByVal lpBuffer As String, ByVal nSize As Long) As Long

' 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 As Long = (-16)
'
Const ICON_CELL As Long = 34&
Const SRCCOPY As Long = &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 CmdAnterior_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
End Sub

Private Sub cmdExaminar_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
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
    Static ultimoDir As String
    '
    If ultimoDir = "" Then
        ultimoDir = AppPath
    End If
    '
    ' 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
        ' usar el último directorio                                 (24/Oct/02)
        .Drive1 = ultimoDir 'sTmp
        .Dir1.Path = ultimoDir '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
            ultimoDir = .Dir1
        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 CmdGrabar_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
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
    If cmdPrimero.Visible Then
        cmdPrimero.SetFocus
    End If
End Sub

Private Sub cmdMas_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
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 cmdPrimero_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
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 = Trim$(Str$(IconPos))
        PosicionarShape
    End If
End Sub

Private Function ExtraerIcono(ByVal quePicture As Long, ByVal sPrograma As String, ByVal 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
    ' Calcular el número de columnas para 8 filas de iconos...      (06/Sep/02)
'    nColumnas = txtNumCols ' 20 'nIconos \ 8
'    If nColumnas > 32 Then nColumnas = 32
'    If nColumnas < 14 Then nColumnas = 14
    '
    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 CmdSiguiente_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
End Sub

Private Sub Form_Initialize()
    InitCommonControls
End Sub

Private Sub Form_Load()
    Dim sTmp As String
    '
    mColumnas = 20
    nTwips = Screen.TwipsPerPixelY
    '
    sTmp = App.Title & " v" & App.Major & "." & Format$(App.Minor, "00") & _
           " ©Guillermo 'guille' Som, 1993-"
    ' Mantener el copyright lo más actualizado posible... ;-)
    If Year(Now) > 2002 Then '> 1999
        sTmp = sTmp & Year(Now)
    Else
        sTmp = sTmp & "2002" '"1999"
    End If
    Caption = sTmp
    '
    ' Comprobar si hay algún fichero en la línea de comandos        (24/Oct/02)
    sTmp = Command$
    '
    If Len(sTmp) = 0 Then
        ' Este se mostrará al hacer doble-click en la etiqueta Archivo  (24/Oct/02)
'        ' Usar la función del API GetSystemDirectory                    (06/Sep/02)
'        sTmp = Space$(260)
'        ret = GetSystemDirectory(sTmp, 260)
'        systemDir = Left$(sTmp, ret)
'        Text1.Text = systemDir & "\SHELL32.DLL"
        Text1.Text = AppPath(True) & App.EXEName & ".exe"
    Else
        Text1.Text = sTmp
    End If
    '
    '
    ' 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---
    '
    Timer1.Interval = 100
    Timer1.Enabled = True
End Sub

Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
End Sub

Private Sub Form_Resize()
    Dim minTop As Long
    Static yaEstoy As Boolean
    '
    If yaEstoy Then Exit Sub
    yaEstoy = True
    '
    On Local Error Resume Next

    If WindowState <> vbMinimized Then
        'If Width < 2880 Then Width = 2880
        If Width < 6885 Then Width = 6885

        '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
                    'Width = Width + 60
                End If
                ' igual con el alto...
                If Height - difSH > picScroll2.Height + HScroll1.Height + minTop Then
                    Height = picScroll2.Height + HScroll1.Height - difSH + minTop
                    'Height = Height + 60
                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 + 120
            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
    ' Ajustar las líneas de separación al ancho del formulario      (06/Sep/02)
    Line3DEx1.Resize

    Err = 0
    On Local Error GoTo 0
    '
    yaEstoy = False
End Sub

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

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

    ' Comprobar los errores al examinar                             (26/Feb/01)
    On Error GoTo ErrExaminar

    sTmp = Trim$(Text1.Text)
    sFic = sTmp
    With gsVerFiles
        .Text2.Text = sTmp
        .Extensiones "*.exe;*.dll|*.exe|*.dll|*.*"

        fExt = ".exe"
        i = InStrRev(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
    '
    Exit Sub
    '
ErrExaminar:
    MsgBox "Se ha producido el siguiente error:" & vbCrLf & _
            Err.Number & " " & Err.Description, vbCritical, "Error al examinar"
    Err.Clear
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 Label1_DblClick(Index As Integer)
    Dim sTmp As String
    Dim systemDir As String
    Dim ret As Long
    '
    ' Usar la función del API GetSystemDirectory                    (06/Sep/02)
    sTmp = Space$(260)
    ret = GetSystemDirectory(sTmp, 260)
    systemDir = Left$(sTmp, ret)
    Text1.Text = systemDir & "\SHELL32.DLL"
    bNuevo = True
End Sub

Private Sub Label1_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
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 picScroll2_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
End Sub

Private Sub Picture1_OLEDragDrop(Index As Integer, Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
End Sub

Private Sub Text1_GotFocus()
    ' Seleccionar todo el texto                                     (26/Feb/01)
    With Text1
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
End Sub

Private Sub Text1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    ' Abrir el fichero soltado                                      (26/Feb/01)
    FicheroSoltado Data
End Sub

Private Sub Timer1_Timer()
    ' sólo es para dar tiempo a que se cargue el formulario         (24/Oct/02)
    Timer1.Enabled = False
    'If Command$ <> "" Then
        cmdPrimero_Click
    'End If
End Sub

Private Sub txtNumCols_Change()
    Static yaEstoy As Boolean
    '
    If yaEstoy Then Exit Sub
    yaEstoy = True
    If Len(txtNumCols.Text) > 1 Then
        nColumnas = Val(txtNumCols)
    End If
    yaEstoy = False
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

Private Sub FicheroSoltado(ByVal Data As DataObject)
    ' Para usar cuando se hace Drag & Drop (se suelta un fichero)   (26/Feb/01)
    '
    On Error Resume Next
    '
    ' Comprobamos que lo que se ha soltado sea un fichero
    If Data.GetFormat(vbCFFiles) Then
        Text1.Text = Data.Files(1)
        ' Comprobar que existe el fichero...
        ' (realmente no es necesario, ya que se supone que se ha soltado,
        ' pero... nunca está de más)
        If Len(Dir$(Text1.Text)) Then
            ' Mostrar los iconos del fichero seleccionado
            bNuevo = True
            cmdPrimero_Click
        End If
    End If
    '
    Err = 0
End Sub

Private Property Get nColumnas() As Long
    nColumnas = mColumnas
End Property

Private Property Let nColumnas(ByVal NewValue As Long)
    ' Calcular para que no sea más ancho que la pantalla            (06/Sep/02)
    Dim cambiar As Boolean
    '
    If NewValue <> mColumnas Then
        If NewValue > 13 Then cambiar = True
        ' si el número de columnas es mayor que el ancho de pantalla
        If ((NewValue + 1) * ICON_CELL) > (Screen.Width \ nTwips) Then
            cambiar = False
        End If
    End If
    If cambiar Then
        mColumnas = NewValue
        bNuevo = True
    End If
    txtNumCols = mColumnas
    txtNumCols.SelStart = Len(txtNumCols.Text)
End Property

Private Function AppPath(Optional ByVal conBackSlash As Boolean = False)
    ' El path de la aplicación                                      (24/Oct/02)
    ' devolverá la barra final si conBackSlash es True
    Dim s As String
    '
    s = App.Path
    If conBackSlash Then
        If Right$(s, 1) <> "\" Then
            s = s & "\"
        End If
    Else
        If Right$(s, 1) = "\" Then
            s = Left$(s, Len(s) - 1)
        End If
    End If
    AppPath = s
End Function

El código del formulario de seleccionar ficheros:


'------------------------------------------------------------------------------
' Utilidad para seleccionar archivos
' Si es un archivo Ico o Bmp, se muestra la imagen
'
' Revisión del 22/Ene/99, nuevo método para asignar las extensiones a usar
'
' ©Guillermo 'guille' Som, 199?-2002
'------------------------------------------------------------------------------
Option Explicit
Const ANCHOMENU = 360 * 3

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, _
     ByVal wParam As Long, ByVal lParam As String) As Long

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
    '
    On Error Resume Next
    '
    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
    '
    Err = 0
End Sub

Private Sub Combo1_Click()
    ' 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 cmdOk_Click()
    ' Aceptar
    ' Asignar la imagen
    Hide
End Sub

Private Sub cmdCancel_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 "*.vb"
    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)
            L = SendMessage(cList.hWnd, CB_FINDSTRING, -1, sTexto)
        Else
            ' no es un Combo, salir
            Exit Sub
        End If
    End If
End Sub

Public Sub Extensiones(ByVal sExts As String)
    ' Asignar las extensiones a usar                                (22/Ene/99)
    ' estarán en el formato habitual: *.*|*.ico... pero sin descripción
    Dim i As Long
    Dim sUnaExt As String

    sExts = Trim$(sExts)
    ' Comprobar que al final exista una barra de separación...
    If Right$(sExts, 1) <> "|" Then
        sExts = sExts & "|"
    End If

    Combo1.Clear
    Do
        i = InStr(sExts, "|")
        If i Then
            sUnaExt = Left$(sExts, i - 1)
            sExts = Mid$(sExts, i + 1)
            Combo1.AddItem sUnaExt
        End If
    Loop While i > 0 Or Len(sExts)
End Sub

El código del módulo de convertir BMPs a ICO:


'----------------------------------------------------------------------------------
'Módulo Bmp2Ico.bas
'
'From: Morcillo, Eduardo A. (E-mail) <[email protected]>
'Date: domingo, 10 de enero de 1999 00:57
'
'Te envio un modulo con dos funciones que creo que son utiles.
'La primera es para crear objetos StdPicture a partir de handles de iconos,
'bitmaps o metafiles.
'La segunda crea iconos (en objetos StdPicture) a partir de bitmaps en
'objetos StdPicture.
'El codigo esta bastante comentado. La primera funcion la he sacado del
'Knowledge Base de Microsoft y la segunda esta hecha 100% por mi.
'
'NOTA:
' Necesita una referencia a: STDOLE2.TLB (OLE Automation / Automatización OLE)
'----------------------------------------------------------------------------------
Option Explicit

Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hgdiObj As Long
    hPalOrXYExt As Long
End Type

Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PICTDESC, riid As IID, ByVal fOwn As Boolean, lplpvObj As Object)

Public Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
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
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long

Public Const HALFTONE As Long = 4

'-------------------------------------------------------------------------
' BMPToIcon: Crea un icono a partir de un bitmap
'
' Parametros:
'
'   Bitmap: El objeto Picture desde en cual se encuentra
'           el bitmap
'   IconCX: El ancho deseado del icono creado. Si no se especifica
'           es 32
'   IconCY: Igual que IconCX pero es el alto.
'
'-------------------------------------------------------------------------
Public Function BMPToIcon(ByVal Bitmap As IPicture, _
                          Optional ByVal IconCX As Long, _
                          Optional ByVal IconCY As Long) As StdPicture
Dim ScreenDC As Long, BitmapDC As Long, IconoDC As Long
Dim hBmp As Long, hBr As Long
Dim hIcn As Long, hIcnMask As Long
Dim OldPal As Long, II As ICONINFO
Dim R As RECT

    On Error Resume Next

    ' Si no se indica un tama_o de icono
    ' se crea uno de 32x32

    If IconCX = 0 Then IconCX = 32
    If IconCY = 0 Then IconCY = 32

    If Bitmap Is Nothing Then
        ' Si el bitmap es Nothing devuelvo
        ' Nothing como resultado de la funcion

        Set BMPToIcon = Nothing
        Exit Function

    ElseIf Bitmap.Handle = 0 Or Bitmap.Type = vbPicTypeEMetafile Or Bitmap.Type = vbPicTypeMetafile Then
        ' Si el objeto bitmap no contiene una imagen
        ' o es un wmf devuelvo un icono
        ' vacio

        ' Tomo el DC del escritorio (la pantalla)
        ScreenDC = GetWindowDC(0&)

        ' Creo un DC compatible con el del escritorio
        BitmapDC = CreateCompatibleDC(ScreenDC)

        ' Creo dos bitmaps para hacer el icono
        hBmp = CreateCompatibleBitmap(ScreenDC, IconCX, IconCY)
        hIcnMask = CreateBitmap(IconCX, IconCY, 1, 1, ByVal 0&)

        R.Right = IconCX
        R.Bottom = IconCY

        ' Seleciono el bitmap para mascara y lo lleno
        ' con blanco (transparente)
        SelectObject BitmapDC, hIcnMask
        hBr = CreateSolidBrush(&HFFFFFF)
        FillRect BitmapDC, R, hBr
        DeleteObject hBr
        SelectObject BitmapDC, 0&

        ' Seleciono el bitmap para el icono y lo lleno
        ' con el color de fondo de botones
        SelectObject BitmapDC, hBmp
        FillRect BitmapDC, R, 16&

        ' Libero los DC que ya no necesito
        DeleteDC BitmapDC
        ReleaseDC 0&, ScreenDC

    ElseIf Bitmap.Type = vbPicTypeIcon Then
        ' Si Bitmap es un icono
        ' lo devuelvo sin modificaciones

        Set BMPToIcon = Bitmap
        Exit Function

    Else

        ' Bitmap es un mapa de bits valido

        ' Tomo el DC del escritorio (la pantalla)
        ScreenDC = GetWindowDC(0&)

        ' Creo dos DC compatibles con el del escritorio
        BitmapDC = CreateCompatibleDC(ScreenDC)
        IconoDC = CreateCompatibleDC(ScreenDC)

        ' Creo dos bitmaps para hacer la mascara y el icono
        hIcnMask = CreateBitmap(IconCX, IconCY, 1, 1, ByVal 0&)
        hBmp = CreateCompatibleBitmap(ScreenDC, IconCX, IconCY)

        R.Right = IconCX
        R.Bottom = IconCY

        ' Seleciono el bitmap para mascara y lo lleno
        ' con negro (opaco)
        SelectObject IconoDC, hIcnMask
        hBr = CreateSolidBrush(&H0)
        FillRect IconoDC, R, hBr
        DeleteObject hBr
        SelectObject IconoDC, 0&

        ' Selecciono la paleta del bitmap para crear
        ' el icono con la misma paleta
        OldPal = SelectPalette(IconoDC, Bitmap.hPal, True)
        RealizePalette IconoDC

        ' Seteo el modo de Stretch a HALFTONE
        SetStretchBltMode IconoDC, HALFTONE

        ' Selecciono el bitmap de destino el
        ' el DC correspondiente
        SelectObject IconoDC, hBmp

        R.Left = Bitmap.Width / 26.46
        R.Top = Bitmap.Height / 26.46


        If Bitmap.CurDC = 0 Then
            ' Si el bitmap no esta seleccionado en
            ' ningun DC tengo que seleccionarlo
            ' para poder copiarlo.

            SelectObject BitmapDC, Bitmap.Handle

            ' Copio el bitmap original en el nuevo del icono
            ' Las medidas de Width y Height en el objeto Bitmap
            ' viene en HIMETRIS que son aprox. 26 pixels.
            Call StretchBlt(IconoDC, 0, 0, IconCX, IconCY, BitmapDC, 0, 0, R.Left, R.Top, vbSrcCopy)

            SelectObject BitmapDC, 0&
        Else
            ' El bitmap ya esta seleccionado
            ' en un DC

            Call StretchBlt(IconoDC, 0, 0, IconCX, IconCY, Bitmap.CurDC, 0, 0, R.Left, R.Top, vbSrcCopy)
        End If

        ' Libero los DC
        SelectPalette IconoDC, OldPal, True
        SelectObject IconoDC, 0&

        DeleteDC BitmapDC
        DeleteDC IconoDC
        ReleaseDC 0&, ScreenDC
    End If

    ' Creo el icono a partir de
    ' los bitmaps creados
    II.fIcon = True
    II.hbmColor = hBmp
    II.hbmMask = hIcnMask
    hIcn = CreateIconIndirect(II)

    ' Libero los bitmaps creados
    DeleteObject hBmp
    DeleteObject hIcnMask

    ' Creo un objeto IPictureDisp con
    ' el icono recien creado

    Set BMPToIcon = HandleToPicture(hIcn, vbPicTypeIcon, Bitmap.hPal)

    ' El handle del icono no debe ser
    ' borrado debido a que ahora pertenece
    ' al objeto que devuelve la funcion

End Function

'-------------------------------------------------------------------------
' HandleToPicture: Crea un objeto StdPicture a partir de un objeto GDI
'
' Parametros:
'
'   hGDIObject: El handle del objeto GDI.
'   ObjectType: El typo de objeto especificado en hGDIObject.
'         hPal: El handle a la paleta del objeto.
'
'-------------------------------------------------------------------------
Public Function HandleToPicture(ByVal hGDIObject As Long, _
                                ByVal ObjectType As PictureTypeConstants, _
                                Optional ByVal hPal As Long = 0) As StdPicture
Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID

    ' Fill picture description

    picdes.cbSizeOfStruct = Len(picdes)
    picdes.picType = ObjectType
    picdes.hgdiObj = hGDIObject
    picdes.hPalOrXYExt = hPal

    ' IPictureDisp {7BF80981-BF32-101A-8BBB-00AA00300CAB}

    iidIPicture.Data1 = &H7BF80981
    iidIPicture.Data2 = &HBF32
    iidIPicture.Data3 = &H101A
    iidIPicture.Data4(0) = &H8B
    iidIPicture.Data4(1) = &HBB
    iidIPicture.Data4(2) = &H0
    iidIPicture.Data4(3) = &HAA
    iidIPicture.Data4(4) = &H0
    iidIPicture.Data4(5) = &H30
    iidIPicture.Data4(6) = &HC
    iidIPicture.Data4(7) = &HAB

    ' Create picture from bitmap handle

    OleCreatePictureIndirect picdes, iidIPicture, True, ipic
    ' Result will be valid Picture or Nothing—either way set it

    Set HandleToPicture = ipic

End Function

El código del control para dibujar líneas 3D:


'------------------------------------------------------------------------------
' xShadowLine                                                       (29/Ago/98)
' Line3DEx Nuevo nombre y nuevas propiedades                        (16/Ene/99)
'
' Un control MUY simple para simular líneas sombreadas (3D)
'
'
' ©Guillermo 'guille' Som, 1998-2002
'------------------------------------------------------------------------------
Option Explicit

' Alineación de la línea (izquierda, centro, derecha)               (18/Ene/99)
Public Enum eL3DAlignment
    [Left Justify]
    [Right Justify]
    [Center]
    [None]
End Enum
Private m_Alignment As eL3DAlignment
' Porcentaje de ancho de las líneas en el contenedor                (18/Ene/99)
Private m_WidthPercent As Long
' Separación desde la izquierda del borde del contenedor            (18/Ene/99)
' (este mismo valor se aplica a la derecha), el valor por defecto es 90
Private m_IndentValue As Long
' Si se ajusta automáticamente al ancho del contenedor              (16/Ene/99)
Private m_AdjustWidth As Boolean

Private Sub UserControl_Initialize()
    m_AdjustWidth = False
    m_IndentValue = 0&
    m_WidthPercent = 0&
    m_Alignment = [None]
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_AdjustWidth = PropBag.ReadProperty("AdjustWidth", False)
    m_IndentValue = PropBag.ReadProperty("IndentValue", 0)
    m_WidthPercent = PropBag.ReadProperty("WidthPercent", 0)
    m_Alignment = PropBag.ReadProperty("Alignment", [None])
End Sub

Private Sub UserControl_Resize()
    Dim i As Long
    Static Estoy As Boolean

    If Not Estoy Then
        Estoy = True

        ' Si se debe ajustar automáticamente al ancho del contenedor
        If m_AdjustWidth Then
            If TypeOf Extender.Parent Is Frame Then
                Extender.Left = 30
            Else
                Extender.Left = 0
            End If
            ' Si se especifica el valor de indentación
            Extender.Left = Extender.Left + m_IndentValue
            Width = Extender.Parent.ScaleWidth - (Extender.Left * 2)
        Else
            ' Si se especifica el porcentaje
            If m_WidthPercent Then
                Width = Extender.Parent.ScaleWidth * m_WidthPercent \ 100
            End If
            ' Si se especifica la alineación
            If m_Alignment = [Left Justify] Then
                Extender.Left = 0
            ElseIf m_Alignment = [Right Justify] Then
                Extender.Left = Extender.Parent.ScaleWidth - Width
            ElseIf m_Alignment = [Center] Then
                Extender.Left = (Extender.Parent.ScaleWidth - Width) \ 2
            End If

        End If

        ' Tamaño del control
        If UserControl.Height <> 30 Then
            UserControl.Height = 30
        End If

        ' Posicionar las lineas
        For i = 0 To 1
            With Line1(i)
                .x1 = 0
                .X2 = UserControl.ScaleWidth
                .y1 = 15
                .Y2 = 15
            End With
        Next
        Estoy = False
    End If
End Sub

Public Property Get AdjustWidth() As Boolean
    AdjustWidth = m_AdjustWidth
End Property

Public Property Let AdjustWidth(ByVal NewValue As Boolean)
    ' Si se ajusta automáticamente al ancho del contenedor
    m_AdjustWidth = NewValue

    ' No usar las propiedades que no son compatibles
    m_Alignment = None
    m_WidthPercent = 0&

    UserControl_Resize
End Property

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("AdjustWidth", m_AdjustWidth, False)
    Call PropBag.WriteProperty("IndentValue", m_IndentValue, 0)
    Call PropBag.WriteProperty("WidthPercent", m_WidthPercent, 0)
    Call PropBag.WriteProperty("Alignment", m_Alignment, [None])
End Sub

Public Property Get IndentValue() As Long
    IndentValue = m_IndentValue
End Property

Public Property Let IndentValue(ByVal NewValue As Long)
    ' Nuevo valor de indentación
    m_IndentValue = NewValue

    ' No usar las propiedades que no son compatibles
    m_Alignment = None
    m_WidthPercent = 0&

    ' Reajustar el tamaño de las líneas
    UserControl_Resize
End Property

Public Property Get WidthPercent() As Long
    WidthPercent = m_WidthPercent
End Property

Public Property Let WidthPercent(ByVal NewValue As Long)
    ' Asignar el nuevo porcentaje de ventana
    ' Si es un valor no válido, usar el 50%
    If NewValue < 0 Or NewValue > 100 Then
        NewValue = 50
    End If
    m_WidthPercent = NewValue
    ' Quitar los valores no compatibles
    m_AdjustWidth = False
    m_IndentValue = 0&
    UserControl_Resize
End Property

Public Property Get Alignment() As eL3DAlignment
    Alignment = m_Alignment
End Property

Public Property Let Alignment(ByVal NewValue As eL3DAlignment)
    m_Alignment = NewValue

    ' Quitar los valores no compatibles
    m_AdjustWidth = False
    m_IndentValue = 0&

    UserControl_Resize
End Property

Public Sub Resize()
    ' Redimensionar el control
    UserControl_Resize
End Sub