Notas:
|
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 SubLas 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.
