Trucos y rutinas para
Visual Basic (1� parte)
Actualizado el 29/Dic/2004
La página con los links de TODOS los trucos
Contenido:
- 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 ShellLas funciones del API de Windows utilizadas son:Para extraer el icono del programa: ExtractIcon GetClassWord DrawIcon Para comprobar las ventanas activas: GetWindow GetWindowText GetWindowTextLength IsWindowVisibleBaja 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 If15.- 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 VB5El 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 brillanteEjemplo 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.