Trucos para Visual Basic 1ª parte

Trucos y rutinas para
Visual Basic (1ª parte)

Actualizado el 29/Dic/2004

La página con los links de TODOS los trucos

Contenido:

Mover un Form sin caption ¡Al fin un método sencillo! (revisado para XP)
Mover y soltar controles con Drag & Drop (AL FIN!)
Cambiar el tamaño de un Picture usando el API de Windows
Métodos para usar el CommonDialog de Visual Basic
Crear controles que se pueden cambiar de tamaño usando el API de Windows
Extraer iconos usando librerías del API de Windows
Añadir a la lista de un Combo el texto escrito
Imitar un Combo Box al estilo del de ayuda.
Scroll horizontal para un List Box usando SendMessage
Text-Box con 64 KB en lugar de 32 KB
Comprobar si un programa cargado con Shell se está ejecutando
Catálogo de CD's musicales
Más trucos usando el API de Windows (16 y 32 bits)
Dejar una ventana siempre visible
Seleccionar el texto al entrar en un TextBox
Mostrar la posición del cursor al editar un TextBox
Refrescar un control con DoEvents
Mostrar el texto "marcado" de un CheckBox al seleccionarlo
Crear una lista de CheckBox (ChkList)
Usa tu computadora para ganar dinero...
Otra forma de usar VScroll y HScroll...

Notas:

Todos estos ejemplos y rutinas son de libre uso.
Si tienes algunos que quieras que se añadan, sólo tienes que enviármelo por e-mail
Cuando haya una cantidad más o menos "considerable", veré de crear un fichero de ayuda.
Cualquier comentario SIEMPRE es bienvenido.
Gracias por colaborar.

1.-Mover un Form sin caption ¡Al fin un método sencillo!

'--------------------------------------------------------------------
'NOTAS:
'Listado a insertar en un módulo (.bas)
'si se quiere poner en un formulario (.frm)
'declarar la función como Private y quitar el Global de las constantes
'--------------------------------------------------------------------
'Constantes y declaración de función:
'
'Constantes para SendMessage
Global Const WM_LBUTTONUP = &H202
Global Const WM_SYSCOMMAND = &H112
Global Const SC_MOVE = &HF010
Global Const MOUSE_MOVE = &HF012

#If Win32 Then
	Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
#Else
	Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
#End If
'
'
'Este código se pondrá en el Control_MouseDown...
'
Dim lngRet As Long

'Simular que se mueve la ventana, pulsando en el Control
If Button = 1 Then
	'Envía un MouseUp al Control
	lngRet = SendMessage(Control.hWnd, _
	WM_LBUTTONUP, 0, 0)
	'Envía la orden de mover el form
	lngRet = SendMessage(FormX.hWnd, _
	WM_SYSCOMMAND, MOUSE_MOVE, 0)
End If

Código para usar en Windows 2000 y Windows XP (29/Dic/04)

Pues eso... aunque sea una "pila" de años después, aquí tienes el código "recomendable" para usar con los sistemas operativos de la familia NT: Windows 2000, Windows XP y Windows 2003.

El tema consiste en usar los valores "adecuados" de las constantes y en utilizar ReleaseCapture... no me preguntes porqué, ya que esta "aportación" la recibí hace años de un "lector", (cuyo nombre no recuerdo, pero si doy con el e-mail en el que me lo dijo lo pondré, ya que suelo guardar todos los correos que recibo), y ayer de casualidad me topé con ella, y como creo que es interesante, la publico ahora... ¡más vale tarde que nunca!

Además, en este ejemplo, he usado varios tipos de controles: Picture, Label y CommandButton para que veas que se puede usar cualquier control para mover el formulario, de hecho utilizo un método genérico para indicarle al Windows de que debe mover el formulario.
Como puedes comprobar en el código, lo mismo da hacerlo en el evento MouseDown que MouseMove.

Aquí tienes una captura del formulario en tiempo de diseño y más abajo el código completo.

El formulario en tiempo de diseño

'------------------------------------------------------------------------------
' Mover un form sin caption, pulsando en cualquier control          (27/Mar/00)
' Probado en Windows 2000 y XP
' Actualizado usando un método                                      (29/Dic/04)
'
' ©Guillermo 'guille' Som, 2000-2004
'------------------------------------------------------------------------------
Option Explicit

' Constantes y declaración de función:
'
' Constantes para SendMessage
Const WM_SYSCOMMAND As Long = &H112&
Const MOUSE_MOVE As Long = &HF012&

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

Private Sub cmdCerrar_Click()
    Unload Me
End Sub

Private Sub cmdCerrar_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' ¡incluso con el botón de cerrar!
    If Button = vbLeftButton Then
        moverForm
    End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        moverForm
    End If
End Sub

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        moverForm
    End If
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        moverForm
    End If
    '
'    ' Este código se pondrá en el Control_MouseDown...
'    ' (sólo válido si el control tiene hWnd)
'    '
'    Dim res As Long
'    Const WM_LBUTTONUP As Long = &H202
'
'    ' Simular que se mueve la ventana, pulsando en el Control
'    If Button = vbLeftButton Then
'        ' Envía un MouseUp al Control
'        res = SendMessage(Me.Picture1.hWnd, WM_LBUTTONUP, 0, 0)
'        ' Envía la orden de mover el form
'        ReleaseCapture
'        res = SendMessage(Me.hWnd, WM_SYSCOMMAND, MOUSE_MOVE, 0)
'    End If
End Sub

Private Sub moverForm()
    Dim res As Long
    '
    ReleaseCapture
    res = SendMessage(Me.hWnd, WM_SYSCOMMAND, MOUSE_MOVE, 0)
End Sub

2.-Mover y soltar controles con Drag & Drop (AL FIN!)

'--------------------------------------------------------------------
'Me ha costado cogerle el tranquillo al tema del Drag & Drop,
'ya que los ejemplos no ayudaban mucho para lo que yo lo quería.
'Se usan: DragOver, DragDrop, MouseDown y MouseUp.
'El único coñazo es tener que poner código en todos los controles...
'--------------------------------------------------------------------
'Variables a nivel del módulo
Dim DY As Single
Dim DX As Single

Private Sub CancelarDrag(Source As Control)
    Source.Visible = True
    Source.Drag vbCancel
End Sub

Private Sub FinalizarDrag(Source As Control, Button As Integer)
    If Button = vbLeftButton Then
        Source.Visible = True
        Source.ZOrder
        Source.Drag vbEndDrag
    End If
End Sub

Private Sub IniciarDrag(Source As Control, Button As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        DX = X
        DY = Y
        'Permitir la operación de Drag & Drop
        Source.Drag vbBeginDrag
        'Cambiar a no visible, ya que si no, el form no detectaría que se ha soltado, si el puntero del ratón no sale del control.
        Source.Visible = False
        'Comienza el espectáculo
        Source.Drag
    End If
End Sub

Private Sub Form_DragDrop(Source As Control, X As Single, Y As Single)
    'Si se quieren excluir algunos controles,
    'hacer aquí la comparación.
    Source.Visible = True
    Source.Move X - DX -60, Y - DY -60
    Source.Drag vbEndDrag
    Source.ZOrder
End Sub

'En cada control poner este código:
(cambiar %Control% por el nombre apropiado)
'
Private Sub %Control%_DragDrop(Source As Control, X As Single, Y As Single)
    CancelarDrag Source
End Sub
'
Private Sub %Control%_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    IniciarDrag %Control%, Button, X, Y
End Sub
'
Private Sub %Control%_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    FinalizarDrag %Control%, Button
End Sub
'
'Se puede añadir DragOver para que muestre un icono no permitiendo que se suelte.
'

3.-Cambiar el tamaño de un Picture usando el API de Windows

'--------------------------------------------------------------------
'Redimensionar un Picture usando el API de Windows
'Funciones usadas: GetWindowLong, SetWindowLong y SetWindowPos
'El ejemplo tiene en el Form los siguientes objetos:
'Label1() y Text1() en cada PicColumn()
'Label2() en el form
'--------------------------------------------------------------------
'
'
Option Explicit
'Prueba para redimensionar Pictures

Dim NumColumnas As Integer
Dim NumFilas As Integer
Dim bIniciando As Boolean

#If Win32 Then
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As Long
#Else
    Private Declare Function GetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Long
    Private Declare Function SetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
    Private Declare Function SetWindowPos Lib "User" (ByVal hwnd%, ByVal hWndInsertAfter%, ByVal X%, ByVal Y%, ByVal cX%, ByVal cY%, ByVal wFlags%) As Integer
#End If
Const GWL_STYLE = (-16)
Const WS_THICKFRAME = &H40000
Const WS_CHILD = &H40000000
Const SWP_DRAWFRAME = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4

Private Sub Form_Load()

    Dim Style as Long

    bIniciando = True

    Style = GetWindowLong(PicColum(0).hwnd, GWL_STYLE)
    Style = Style& Or WS_THICKFRAME
    Style = SetWindowLong(PicColum(0).hwnd, GWL_STYLE, Style)
    Style = SetWindowPos(PicColum(0).hwnd, _
        Me.hwnd, 0, 0, 0, 0, SWP_NOZORDER Or _
        SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME)

    NumFilas = 2
    Load Text1(1)
    Set Text1(1).Container = PicColum(0)
    Text1(1).Visible = True
    Text1(1).Top = Text1(0).Top + Text1(0).Height
    Load Label2(1)
    Label2(1).Visible = True
    Label2(1).Top = Label2(0).Top + Label2(0).Height
    Label2(1) = "Fila 2"
    NumColumnas = 1
    bIniciando = False

End  Sub

Private Sub PicColum_Resize(Index As Integer)
    Dim k As Integer
    Dim i As Integer

    If bIniciando Then Exit Sub

    'ajustar el ancho del Label y los texts
    Label1(Index).Width = PicColum(Index).Width
    For i = 0 To NumFilas - 1
        k = i * NumColumnas + Index
        Text1(k).Width = PicColum(Index).Width
    Next
    PicColum(0).Left = Label2(0).Width
    For i = 0 To NumColumnas - 1
        If i > 0 Then
            PicColum(i).Left = PicColum(i - 1).Left + PicColum(i - 1).Width
        End If
        PicColum(i).Top = 0
    Next
End Sub

4.-Métodos para usar el CommonDialog de Visual Basic

'--------------------------------------------------------------------
'Ejemplos de los métodos para Seleccionar Impresora, Abrir, Guardar
'--------------------------------------------------------------------
'Seleccionar impresora
    On Local Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlPDPrintSetup
    CommonDialog1.ShowPrinter
    Err = 0

'Abrir
    On Local Error Resume Next
    CommonDialog1.CancelError = True
    'Especificar las extensiones a usar
	CommonDialog1.DefaultExt = "*.crd"
    CommonDialog1.Filter = "Cardfile (*.crd)|*.crd|Textos (*.txt)|*.txt|Todos los archivos (*.*)|*.*"
    CommonDialog1.ShowOpen
    If Err Then
        'Cancelada la operación de abrir
    Else
        sArchivo = CommonDialog1.FileName
    End If

'Guardar
    On Local Error Resume Next
    CommonDialog1.CancelError = True
	'Especificar las extensiones a usar
    CommonDialog1.DefaultExt = "*.crd"
    CommonDialog1.Filter = "Cardfile (*.crd)|*.crd|Textos (*.txt)|*.txt|Todos los archivos (*.*)|*.*"
    CommonDialog1.FileName = sArchivo
    CommonDialog1.ShowSave
    If Err Then
        'Cancelada la operación de guardar
    Else
        sArchivo = CommonDialog1.FileName
    End If

5.-Crear controles que se pueden cambiar de tamaño usando el API de Windows

'--------------------------------------------------------------------
'Convertir controles en VENTANAS. Poder cambiar el tamaño, etc.
'Funciones usadas: GetWindowLong, SetWindowLong y SetWindowPos
'--------------------------------------------------------------------
'
'Declaraciones globales a nivel de módulo
'
#If Win32 Then
    Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
    Declare Function GetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Long
    Declare Function SetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
    Declare Function SetWindowPos Lib "User" (ByVal hwnd%, ByVal hWndInsertAfter%, ByVal X%, ByVal Y%, ByVal cX%, ByVal cY%, ByVal wFlags%) As Integer
#End If
Global Const GWL_STYLE = (-16)
Global Const WS_THICKFRAME = &H40000
Global Const WS_CHILD = &H40000000

Global Const SWP_DRAWFRAME = &H20
Global Const SWP_NOMOVE = &H2
Global Const SWP_NOSIZE = &H1
Global Const SWP_NOZORDER = &H4

Private Sub Form_Load()
    Dim Style&, ret&

    'Cambiar %Control% por el control a usar: (Text, Picture...)
	Style& = GetWindowLong(%Control%.hWnd, GWL_STYLE)
    Style& = Style& Or WS_THICKFRAME
    Style& = SetWindowLong(%Control%.hWnd, GWL_STYLE, Style&)
    ret& = SetWindowPos(%Control%.hWnd, _
        Me.hWnd, 0, 0, 0, 0, SWP_NOZORDER Or _
        SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME)

End Sub

6.-Extraer iconos usando librerías del API de Windows

'--------------------------------------------------------------------
'Extraer iconos de una aplicación o librería y dibujarlo en un picture.
'Usando librerías del Api de Windows (ExtractIcon GetClassWord DrawIcon)
'--------------------------------------------------------------------
'
'Declaraciones para extraer iconos de los programas
'
'Versión 32 bits
'
'hIcon el número de icono a extraer, el 0 es el primero.
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Declare Function GetClassWord Lib "user32" Alias "GetClassWord" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function DrawIcon Lib "user32" Alias "DrawIcon" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Const GCW_HMODULE = (-16&)

Function ExtraerIcono (quePicture As Integer, sPrograma As String, queIcon As Long) As Long
    'Cargar el icono del programa
    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
        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

'
'Versión para 16 bits
'
'hIcon el número de icono a extraer, el 0 es el primero.
Declare Function ExtractIcon Lib "Shell" (ByVal hInstance As Integer, ByVal pszExeName As String, ByVal hIcon As Integer) As Integer
Declare Function GetClassWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function DrawIcon Lib "User" (ByVal hDC As Integer, ByVal x As Integer, ByVal Y As Integer, ByVal hIcon As Integer) As Integer
Const GCW_HMODULE = (-16)

Function ExtraerIcono (quePicture As Integer, sPrograma As String, queIcon As Integer) As Integer
    'Cargar el icono del programa
    Dim myhInst As Integer
    Dim hIcon As Integer
    Dim i As Integer

    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

7.-Añadir a la lista de un Combo el texto escrito

'--------------------------------------------------------------------
'Añadir a la lista de un combo, el texto escrito, si es que no está.
'Usarlo del tipo: 0-DropDown Combo
'--------------------------------------------------------------------
Sub ActualizarCombo()
    'Actualizar el contenido del Combo
    Dim sTmp As String
    Dim i As Integer
    Dim j As Integer
    Dim hallado As Boolean
    Dim k As Integer

    For k = 0 To 1
        hallado = False
        sTmp = Combo1(k).Text
        If Len(Trim$(sTmp)) Then
            j = Combo1(k).ListCount - 1
            For i = 0 To j
                If StrComp(Trim$(sTmp), Trim$(Combo1(k).List(i))) = 0 Then
                    hallado = True
                    Exit For
                End If
            Next
            If Not hallado Then
                Combo1(k).AddItem sTmp
            End If
        End If
    Next
End Sub

8.-Imitar un Combo Box al estilo del de ayuda.

'--------------------------------------------------------------------
'Para imitar un ComboBox parecido al de Buscar en Ayuda de Windows,
'(va cambiando según las letras escritas).
'El form debe tener un Textbox y un Listbox.
'--------------------------------------------------------------------
'
'Código en un Módulo (.BAS):

Option Explicit
Global CHClickList As Integer
Global CHInChange  As Integer

Sub CtrlTB_Change (OTB As TextBox, OLB As ListBox)
    Dim Pos As Integer, I As Integer, L As Integer
    Dim Aux As String

    If CHClickList Then
        CHClickList = False
        Exit Sub
    End If

    Aux = OTB.Text

    L = Len(Aux)
    For I = 0 To (OLB.ListCount - 2)
        If Not StrComp(Aux, Left$(OLB.List(I), L), 1) > 0 Then
            Exit For
        End If
    Next I

    OLB.TopIndex = I
    OLB.ListIndex = I
End Sub

Sub CtrlTB_KeyPress (OTB As TextBox, OLB As ListBox, KeyAscii As Integer)
    If KeyAscii = 13 Then
        OTB.Text = Left$(OLB.List(OLB.ListIndex), 60)
        CHInChange = False
    Else
        CHInChange = True
    End If
End Sub

Sub CtrlLB_Click (OTB As TextBox, OLB As ListBox)
    If Not CHInChange Then
        OTB.Text = Left$(OLB.List(OLB.ListIndex), 60)
    Else
        CHInChange = False
    End If
End Sub

Sub CtrlLB_MouseDown ()
    CHClickList = True
End Sub

'Código en el Form (.FRM):

Sub List1_Click ()
   CtrlLB_Click Text1, List1
End Sub

Sub List1_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
   CtrlLB_MouseDown
End Sub

Sub Text1_Change ()
    CtrlTB_Change Text1, List1
End Sub

Sub Text1_KeyPress (KeyAscii As Integer)
   CtrlTB_KeyPress Text1, List1, KeyAscii
End Sub

9.-Scroll horizontal para un List Box usando SendMessage

'--------------------------------------------------------------------
'Como poner una barra de scroll horizontal en un List Box.
'"Truco" tomado de Microsoft Knowledge Base Articles.
'How to Add a Horizontal Scroll Bar to Visual Basic List Box; Article ID: Q80190
'Función: SendMessage
'--------------------------------------------------------------------
'Declaraciones de las funciones para 16 y 32 bits
'Para 16 bits (VB3 y VB4)
Declare Function SendMessage Lib "user" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%, ByVal lParam&) As Integer
'
'Para 32 bits usar:
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
'
'
'Poner en Form_Activate
Const LB_SETHORIZONTALEXTENT = &H400 + 21
Const NULO = &O0
Dim ListhWnd As Integer  'Handle del List Box
Dim ListLen As Integer   'Ancho del List Box
Dim iTmp As Integer      'Para el valor devuelto por SendMessage
Dim ScaleTmp As Integer  'Valor anterior de ScaleMode

ScaleTmp = ScaleMode
ScaleMode = 3            'wParam is in PIXEL(3)
ListhWnd = List1.hWnd
ListLen = 32767          'TextWidth(String$(256, "A"))
iTmp = SendMessage(ListhWnd, LB_SETHORIZONTALEXTENT, ListLen, NULO)
ScaleMode = ScaleTmp     'Restablecer el valor anterior de ScaleMode

10.-TextBox con 64 KB en lugar de 32 KB

'--------------------------------------------------------------------
'Usando SendMessage del Api de Windows, poder tener text-box con 64 KB
'en lugar de los 32 que admite Visual Basic.
'--------------------------------------------------------------------
'Declaración de la función API
Declare Function sendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
'
'Para 32 bits usar:
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
'
'Declaración de las constantes
Global Const WM_USER = &H400
Global Const EM_LIMITTEXT = WM_USER + 21
'En el Form_Load del text-box:
Dim LTmp as long
LTmp=SendMessage(Text1.hWnd,EM_LIMITTEXT,0,byval 0&)

11.-Comprobar si un programa cargado con Shell está ejecutandose

'----------------------------------------------------------------------
'Por ser extenso para un "simple" truco, los ejemplos están comprimidos
'También se muestra como asignar el icono de un programa a un picture
'Hay un fichero para VB4 (16 y 32 bits) y otro para VB3
'----------------------------------------------------------------------
La idea básica es:
1.- Cargar el programa usando Shell
2.- Comprobar si aún está activo (bucle)
3.- Continuar el programa principal una vez finalizado el programa cargado con Shell

Las funciones del API de Windows utilizadas son:

    Para extraer el icono del programa:
    ExtractIcon
    GetClassWord
    DrawIcon
    Para comprobar las ventanas activas:
    GetWindow
    GetWindowText
    GetWindowTextLength
    IsWindowVisible

Baja los ejemplos del truco 11: Shell_t.zip (11.606 bytes)

12.- Catálogo de CD's musicales

Ejemplo para leer el volumen de un disco, esta función se puede usar para ¡catalogar los CD's musicales!

Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Dim lVSN As Long, n As Long, s1 As String, s2 As String
s1=String$(255,Chr$(0))
s2=String$(255,Chr$(0))
l= GetVolumeInformation("unidad", s1, Len(s1), lVSN, 0, 0, s2, Len(s2))
'lVSN tendrá el valor del Volume Serial Number (número de serie del volumen)

Si "unidad" es el CD-ROM y tenemos un disco de música, podemos usar el VSN para hacer un catálogo de CD's ya que cada CD tiene un número diferente.

Para comprobar si es un CD-ROM (o CD-musical):

' Valores de retorno de GetDriveType
Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6
Declare Function GetDriveType Lib "Kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Dim lDrive As Long
Dim szRoot As String

szRoot="D:\" 'Poner aquí la unidad del CD-ROM o la que queramos comprobar
lDrive= GetDriveType(szRoot)
If lDrive = DRIVE_CDROM Then
    'Es un CD-ROM/Compact-Disc
End If

15.- Seleccionar el texto al entrar en un TextBox

Este truco, creo que es conocido por todos, pero lo "recuerdo" por si hay alguno no lo sabe...

'Para un control
Private Sub Text1_GotFocus()
	Text1.SelStart = 0
	Text1.SelLength = Len(Text1)
End Sub

'Para un array
Private Sub Text1_GotFocus(Index As Integer)
	Text1(Index).SelStart = 0
	Text1(Index).SelLength = Len(Text1(Index))
End Sub

16.- Mostrar la posición del cursor en un TextBox

Este truco, muestra la posición actual del cursor y la longitud total del TextBox. Por supuesto el tamaño máximo permitido, debemos asignarlo a Text1.MaxLength, yo lo uso en mis programas, para saber cuando tengo que empezar a abreviar lo que estoy escribiendo, no siempre se dispone de todo el espacio que uno quiere, sobre todo cuando no quieres que las bases de datos se hagan enormes!

'Se puede cambiar StatusBar por cualquier control que nos muestre la información...
Private Sub Text1_Click()
	miForm!StatusBar1.Panels("Posic").Text = " Pos: " & Text1.SelStart + 1 _
		 & "/" & Text1.MaxLength
End Sub

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
	miForm!StatusBar1.Panels("Posic").Text = " Pos: " & Text1.SelStart + 1 _
		& "/" & Text1.MaxLength
End Sub

17.- Refrescar el contenido de un control con DoEvents

¿Cuantas veces has asignado a un Label un nuevo Caption y no lo ha mostrado?, prueba a poner DoEvents después de la asignación y verás como se muestra enseguida.

Puedes usar Sleep 0& en lugar de DoEvents. La explicación de este consejo.

18.- Mostrar el texto de un CheckBox seleccionado cuando está marcado (7/Ene/97)

Bueno, esto no es realmente un truco, pero podría serlo.
Cuando seleccionamos una opción de un CheckBox, algunas veces, nos puede interesar que el texto se quede "marcado".
Por ejemplo, si quisieramos hacer un list box al estilo del que viene con las FM 2.0 de Microsoft. Y que seguramente estará (o ya está?) en VB5

El truco consiste en cambiar el color del checkbox cuando este está seleccionado.

Private Sub Check1_Click()

    If Check1 Then
        Check1.ForeColor = colForeSelect
        Check1.BackColor = colBackSelect
    Else
        Check1.ForeColor = colForeNormal
        Check1.BackColor = colBackNormal
    End If
End Sub

Las variables colForeSelect, colBackSelect, colForeNormal, colBackNormal, deben estar definidas con los colores que queramos usar. Por ejemplo:

Dim colBackNormal As Long
Dim colForeNormal As Long
Dim colBackSelect As Long
Dim colForeSelect As Long

colBackNormal = Check1.BackColor
colForeNormal = QBColor(0)	'Negro
colBackSelect = QBColor(1)	'Azul
colForeSelect = QBColor(15)	'Blanco brillante

Ejemplo de chk extendido (eje_chk1.zip 1.883 bytes)

19.- Crear una lista de CheckBox, ChkList (8/Ene/97)

Este tipo de control existe en VB5 pero no en los anteriores, salvo que sea en un VBX/OCX externo.
De lo que se trata es de simular un ListBox, pero en lugar de usar sólo un texto como contenido, se usa un CheckBox. En los listados que se acompañan, hay también un ejemplo de cómo crear un panel deslizable (Picture con Scroll). Para que al mover el scroll vertical u horizontal, se desplace el contenido del CheckList, realmente esta es "la madre del cordero". También he creado un Picture dimensionable, usando el API de Windows, para poder cambiar "manualmente" el tamaño del contenedor del ChkList en tiempo de ejecución.

Listado del ejemplo de ChkList (chklist.zip 2.811 bytes)

20.- Usa tu computadora para ganar dinero fácil y rápido... (14/Ene/97)

De nuevo Joe LeVasseur... La rutina es para saber si puedes ganar dinero rápido... sin hacer nada.

Public Function Dinero_Rapido() As Boolean
    Dim Tonto
    Dim No_Quiere_Trabajar
    If No_Quiere_Trabajar And Tonto Then
	Dinero_Rapido = True
    Else
	Dinero_Rapido = False
	Tonto = False
    End If
End Function

Private Sub Command1_Click()
    Print Dinero_Rapido
End Sub

'Pruebalo, siempre tiene el mismo resultado.

Bueno, como comprenderás, se trata de una broma. Esta "rutina" fue la respuesta de Joe a Jorge E. Mora en las news, a la propuesta de éste último para ganar $$$$$ DINERO RAPIDO $$$$$$
Te prometo que el próximo truco será de "verdad."

21.- Otra forma de usar VScroll y HScroll... (15/Ene/97)

En realidad es comentar que si al asignar los valores Mínimos y Máximos de estos controles de manera que el valor Máximo sea inferior al Mínimo, se desplazarán al revés.
Cuando se usa de la forma habitual, al pulsar en la flecha superior del VScroll, el valor disminuye.
De esta otra forma, al pulsar arriba, se incrementa.