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:
- Revisado para Windows 2000/XP
- Permite soltar un fichero del que se mostrarán los iconos.
- Averigua el directorio System/System32 para poder acceder a la librería Shell32.dll
- Permite indicar el número de columnas a mostrar, antes era una cantidad fija.
- Al guardar un icono (o BMP), recuerda el directorio, al menos mientras la aplicación está abierta.
- Nuevo icono del ejecutable de 256 colores.
- Permite usar los temas de Windows XP
- Permite indicar un fichero en la línea de comandos (o soltar uno en el ejecutable y abrirlo)
- Añado un fichero de recursos con varios iconos, para que se cargue automáticamente si no se indica otro fichero.
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) <edanmo@geocities.com>
'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
