Dim pokoapoko as String = "Creada el 24/11/2011 actualizo cada semana +/- jeje" & "GRACIAS" 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 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 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 Bueno, esto no es realmente un truco, pero podría
serlo. 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 Este tipo de control existe en VB5 pero no en los anteriores,
salvo que sea en un VBX/OCX externo. Listado del ejemplo
de ChkList (chklist.zip 2.811 bytes) 20.- Usa tu computadora para ganar dinero fácil y rápido... 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 $$$$$$ 21.- Otra forma de usar VScroll y HScroll... 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. 1.- ¿Recursos?: Si, Gracias! Pues el truco con el que empiezo este nuevo archivo
es para simular un Frame usando Shape. 22.- Comprobar cómo se cierra una aplicación Al cerrar un form, podemos saber si es nuestro código
el que cierra la aplicación o bien se cierra por otra causa. QueryUnload Method Constant Value Description vbFormCode 1 Unload method invoked from code. vbAppWindows 2 Current Windows session ending. vbFormMDIForm 4 MDI child form is closing because the MDI form is closing. vbFormControlMenu 0 User has chosen Close command from the Control-menu box on a form. vbAppTaskManager 3 Windows Task Manager is closing the application. 'Ejemplo para usarlas: Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 'Sólo cerrar si es un mensaje de windows Select Case UnloadMode Case vbFormCode, vbAppTaskManager, vbAppWindows 'ok, cerrar Case Else MsgBox "No se permite cerrar la aplicación.", vbInformation, "Mensajes" Cancel = True WindowState = vbMinimized End Select End Sub 23.- Averiguar el signo decimal (coma o punto) (18/Feb) Esto lo he usado para el programa de la calculadora y
lo copié de un ejemplo que venía con el Visual Basic para MS-DOS ' Determine whether "." or "," should be used as
' decimal separator based on value returned by
' FORMAT$ (country specific).
temp$ = Format$(1.5, "#.#")
If InStr(temp$, ",") Then
Decimal = ","
Else
Decimal = "."
End If
24.- Usar los IO Ports en con VB 16 y 32 bits (26/Feb) He "bajado" unas librerías de http://www.softcircuits.com/ con
rutinas para manejar los puertos de entrada/salida, además de otras cosillas.
Esto hay que agradecerselo, además de a la gente de softcircuits, a Victor
Limiñana, ya que gracias a una consulta que me hizo sobre este tema, he podido
encontrar estas librerías. La
librería y ejemplos para 16 bits (vbhlp16.zip
37.962 bytes) La
librería de varias utilidades para 32 bits y ejemplos (vbhlp32.zip 30.945) La
librería para IO en Windows95, no
sirve para NT (win95IO.zip 1.676 bytes) 25.- Funciones para leer/escribir en archivos INI (16 y 32 bits) (1/Mar) Estas funciones simulan las que incorpora VB4:
GetSetting y SaveSetting, pero siempre trabajan con archivos INI, no lo hacen
con el registro, como ocurre si el VB4 es 32 bits. '--------------------------------------------------
' Profile.bas (24/Feb/97)
' Autor: Guillermo Som Cerezo, 1997
' Fecha inicio: 24/Feb/97 04:05
'
' Módulo genérico para las llamadas al API
' usando xxxPrivateProfileString
'--------------------------------------------------
Option Explicit
#If Win32 Then
'Declaraciones para 32 bits
Private Declare Function GetPrivateProfileString Lib "Kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "Kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lpFileName As String) As Long
#Else
'Declaraciones para 16 bits
Private Declare Function GetPrivateProfileString Lib "Kernel" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Private Declare Function WritePrivateProfileString Lib "Kernel" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lplFileName As String) As Integer
#End If
'----------------------------------------------------------------------------
'Función equivalente a GetSetting de VB4.
'GetSetting En VB4/32bits usa el registro.
' En VB4/16bits usa un archivo de texto.
'Pero al usar las llamadas del API, siempre se escriben en archivos de texto.
'----------------------------------------------------------------------------
Public Function LeerIni(lpFileName As String, lpAppName As String, lpKeyName As String, _
Optional vDefault) As String
'Los parámetros son:
'lpFileName: La Aplicación (fichero INI)
'lpAppName: La sección que suele estar entrre corchetes
'lpKeyName: Clave
'vDefault: Valor opcional que devolverá
' si no se encuentra la clave.
'
Dim lpString As String
Dim LTmp As Long
Dim sRetVal As String
'Si no se especifica el valor por defecto,
'asignar incialmente una cadena vacía
If IsMissing(vDefault) Then
lpString = ""
Else
lpString = vDefault
End If
sRetVal = String$(255, 0)
LTmp = GetPrivateProfileString(lpAppName, lpKeyName, lpString, sRetVal, Len(sRetVal), lpFileName)
If LTmp = 0 Then
LeerIni = lpString
Else
LeerIni = Left(sRetVal, LTmp)
End If
End Function
'----------------------------------------------------------------------------
'Procedimiento equivalente a SaveSetting de VB4.
'SaveSetting En VB4/32bits usa el registro.
' En VB4/16bits usa un archivo de texto.
'Pero al usar las llamadas del API, siempre se escriben en archivos de texto.
'----------------------------------------------------------------------------
Sub GuardarIni(lpFileName As String, lpAppName As String, lpKeyName As String, lpString As String)
'Guarda los datos de configuración
'Los parámetros son los mismos que en LeerIni
'Siendo lpString el valor a guardar
'
Dim LTmp As Long
LTmp = WritePrivateProfileString(lpAppName, lpKeyName, lpString, lpFileName)
End Sub
26.- Desglosar una ruta/nombre de archivo (1/Mar) Una función para desglosar en el Path y el Nombre del
archivo, la ruta que recibe como parámetro. Public Sub SplitPath(ByVal sTodo As String, sPath As String, Optional vNombre, Optional vExt)
'----------------------------------------------------------------
'Divide el nombre recibido en la ruta, nombre y extensión
'(c)Guillermo Som, 1997 ( 1/Mar/97)
'
'Esta rutina aceptará los siguientes parámetros:
'sTodo Valor de entrada con la ruta completa
'Devolverá la información en:
'sPath Ruta completa, incluida la unidad
'vNombre Nombre del archivo incluida la extensión
'vExt Extensión del archivo
'
'Los parámetros opcionales sólo se usarán si se han especificado
'----------------------------------------------------------------
Dim bNombre As Boolean 'Flag para saber si hay que devolver el nombre
Dim i As Integer
If Not IsMissing(vNombre) Then
bNombre = True
vNombre = sTodo
End If
If Not IsMissing(vExt) Then
vExt = ""
i = InStr(sTodo, ".")
If i Then
vExt = Mid$(sTodo, i + 1)
End If
End If
sPath = ""
'Asignar el path
For i = Len(sTodo) To 1 Step -1
If Mid$(sTodo, i, 1) = "\" Then
sPath = Left$(sTodo, i - 1)
'Si hay que devolver el nombre
If bNombre Then
vNombre = Mid$(sTodo, i + 1)
End If
Exit For
End If
Next
End Sub
27.- Como llamar al Microsoft Internet Mail y News desde un programa VB (5/Mar) Este "truco" me lo ha enviado Joe LeVasseur Pon dos botones en un Form e inserta este código:
Private Sub Command1_Click()
Dim ValDev&, Programa$
Programa = "EXPLORER.EXE /root,c:\windows\Internet Mail." & _
"{89292102-4755-11cf-9DC2-00AA006C2B84}"
ValDev = Shell(Programa, vbNormalFocus)
End Sub
Private Sub Command2_Click()
Dim ValDev&, Programa$
Programa = "EXPLORER.EXE /root,c:\windows\Internet News." & _
"{89292103-4755-11cf-9DC2-00AA006C2B84}"
ValDev = Shell(Programa, vbNormalFocus)
End Sub
Si usas el Microsoft Internet News/Mail,
se arrancan cuando pulsas el botón.
Es que no hay un EXE para ellos- son hijos del Explorer.
Joe
28.- Ejecutar cualquier archivo, incluso accesos directos (LNK) (13/Mar) Esta pregunta me había surgido antes y no encontraba
la "puñetera" respuesta. Probé con el Explorer.exe, al estilo del truco
anterior, pero nada... ¿Cómo se hace? Dim ret As Long
ret = Shell("start " & sFile)
'Si Quieres que no se muestre la ventana:
ret = Shell("start " & sFile, 6)
sFile será "lo que queramos" ejecutar. CUALQUIER COSA! 29.- Un Huevo de Pascua (Easter Egg), el del VB4 (24/Mar) Este "truco" me lo ha mandado el señor Joe LeVasseur
y se trata del Easter Egg del Visual Basic 4, se trata de lo siguiente: 30.- Ejemplo de cómo restar fechas y horas (26/Mar) Dos ejemplos de cómo restar fechas y horas. Crea un form con los siguientes controles, dejale los
nombre por defecto. 'Ejemplo de prueba para restar fechas y horas (26/Mar/97)
'(c) Guillermo Som, 1997
Option Explicit
Private Sub Command1_Click()
Dim t0 As Variant, t1 As Variant
'Text1 Tendrá una fecha anterior
'Text2 tendrá la nueva fecha
t0 = DateValue(Text1)
t1 = DateValue(Text2)
Label1 = t1 - t0
End Sub
Private Sub Command2_Click()
Dim t0 As Variant, t1 As Variant
'Text3 Tendrá una hora anterior
Text4 = Format(Now, "hh:mm:ss")
t0 = Format(Text3, "hh:mm:ss")
t1 = Format(Text4, "hh:mm:ss")
Label2 = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss")
End Sub
Private Sub Form_Load()
'Para probar la diferencia de fechas
Text1 = DateValue(Now)
Text2 = DateValue(Now + 10)
'
'Para probar la diferencia de horas
Text3 = Format(Now, "hh:mm:ss")
Text4 = Format(Now, "hh:mm:ss")
Command1_Click
Command2_Click
End Sub
31.- Leer la línea de comandos y quitarle los 'posibles' caracteres de comillas que tenga. (26/Mar) Algunas veces cuando recibimos un archivo de la línea
de comandos, pueden tener caracteres de comillas, sobre todo si trabajamos con
VB4 de 32 bits. sFile = LineaComandos() Private Function LineaComandos() As String
Dim sTmp As String
Dim i As Integer
'Comprobar si hay algún archivo en la línea de comandos
sTmp = Trim$(Command$)
If Len(sTmp) Then
'Si tiene los caracteres de comillas, quitarselos
i = InStr(sTmp, Chr$(34))
If i Then
sTmp = Left$(sTmp, i - 1) & Mid$(sTmp, i + 1)
i = InStr(sTmp, Chr$(34))
If i Then
sTmp = Left$(sTmp, i - 1) & Mid$(sTmp, i + 1)
End If
End If
End If
LineaComandos = sTmp
End Function
32.- Determinar la Resolución de la pantalla. (10/Abr) Un truco/colaboración/rutina del colega Joe LeVasseur. Option Explicit
' Como determinar resolución de la
' pantalla con VB4-Win95/NT.
' Dos versiones- con el API y sin...
' Pon tres botones y un textbox encima de
' un form y insertar este codigo.
'
' Joe LeVasseur lvasseur@tiac.net
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Sub Command1_Click()
Dim resolucionX&, resolucionY&
resolucionX = GetSystemMetrics(0)
resolucionY = GetSystemMetrics(1)
Text1.Text = CStr(resolucionX & "x" & resolucionY)
End Sub
Private Sub Command2_Click()
Dim resolucionX&, resolucionY&
resolucionX = Screen.Width / Screen.TwipsPerPixelX
resolucionY = Screen.Height / Screen.TwipsPerPixelY
Text1.Text = CStr(resolucionX & "x" & resolucionY)
End Sub
Private Sub Command3_Click()
Text1.Text = ""
End Sub
Private Sub Form_Load()
Text1.Text = ""
Command1.Caption = "&Con API"
Command2.Caption = "&Sin API"
Command3.Caption = "&Borrar"
Me.Caption = "Ejemplo para el Guille"
End Sub
33.- Usar tus propias instrucciones en lugar de las de VB. (29/Jun) Esto no es realmente un truco, es que o lo
adivinas por equivocación o, como en mi caso,
lo lees en un libro. Por ejemplo, (para seguir siendo un "copión"), pongo
el mismo ejemplo que el libro ese que estoy leyendo ahora. Puedes usarla de esta forma: Function Kill(ParamArray vFiles() As Variant) As Boolean
Dim v As Variant
On Error Resume Next
For Each v In vFiles
VBA.Kill v
Next
Kill = (Err = 0)
End Function
El truco está en anteponer VBA. a la instrucción propia del VB y así se sabe exactamente a que se está refiriendo. 34.- Descargar una DLL o EXE que esté en memoria (sólo 16 bits) (6/Jul) Esto puede servir para descargar una aplicación o librería dinámica de la memoria de nuestro Windows. La forma es sencilla, sólo hay que crear un módulo BAS y escribir este código en el SUB MAIN, como parámetro debemos pasarle la DLL o EXE que queremos "eliminar" y este programita se encargará del resto... AVISO: Esto sólo funcionará de forma
correcta en Windows 3.xx NO USARLO EN WINDOWS 95. '--------------------------------------------------------------
'Descargar una DLL o EXE que esté en memoria ( 6/Jul/97)
'
'Basado en un código de Bruce McKinney y que realiza la misma
'tarea que WPS.exe para descargar módulos y ejecutables.
'(se supone)
'--------------------------------------------------------------
Option Explicit
Declare Function GetModuleHandle Lib "Kernel" (ByVal lpModuleName As String) As Integer
Declare Function GetModuleUsage Lib "Kernel" (ByVal hModule As Integer) As Integer
Declare Sub FreeModule Lib "Kernel" (ByVal hModule As Integer)
Public Sub Main()
Dim hModule As Integer
'El módulo a librerar se pasa en la línea de comandos
hModule = GetModuleHandle(Command$)
If hModule = 0 Then Exit Sub
'Libera todas copias de este módulo
Do While GetModuleUsage(hModule) > 0
Call FreeModule(hModule)
Loop
End Sub
35.- Barra de botones al estilo Office y un ToolTip sencillo (6/Ago) Esto no es realmente un truco sino más bien una
pequeña "utilidad", pero creo que encaja bien en este apartado de los
trucos. Pulsa en este otro para ver la revisión del 7/Ago/97 36.- No permitir cambiar el tamaño de una ventana redimensionable (31/Ago) Seguramente te preguntarás ¿que utilidad puede tener
esto? Si a la ventana se le puede cambiar el tamaño, ¿por qué no permitir que se
cambie? Bueno, ahí va: en algunas ocasiones me gusta que los bordes de la ventana se vean de forma "normal", es decir como si se pudiese cambiar el tamaño, pero no me gusta que lo puedan cambiar, así que lo que he hecho en estas ocasiones es simplemente conservar el tamaño inicial de la ventana (el que tiene al cargarse) y cuando el usuario decide cambiarle el tamaño, no permitirselo y volver al que tenía inicialemente. Este "truco" lo mandé ayer día 30 a la lista de VB-ESP, pero tenía un inconveniente: que al cambiar el tamaño por el lado izquierdo o por la parte superior, se movia el form, esto sigue igual, si alguien tiene la forma de conseguirlo, sin que sea dejando el form en la posición inicial, que eso es fácil, sino que recuerde la última posición si sólo se ha movido... Aquí tienes todo el código necesario: '--------------------------------------------------------------
'Prueba para no cambiar el tamaño de una ventana con
'bordes dimensionables (30/Ago/97)
'--------------------------------------------------------------
Option Explicit
'Tamaño inicial del Form
Dim iH As Integer
Dim iW As Integer
Private Sub Form_Load()
'Guardar el tamaño inicial
iH = Height
iW = Width
End Sub
Private Sub Form_Resize()
'Sólo comprobar si el estado es Normal
If WindowState = vbNormal Then
'Si se cambia la altura
If Height <> iH Then
Height = iH
End If
'Si se cambia el ancho
If Width <> iW Then
Width = iW
End If
End If
End Sub
1.- Posicionar el cursor al final de una línea de texto (4/Sep) Ya sabes cómo seleccionar todo el texto de un TextBox, ahora puedes usar esto para posicionarte al final: Text1.SetFocus 'Asegurarnos que reciba el foco
Text1.SelStart = Len(Text1) 'La posición del caracter inicial es la longitud del texto...
'por tanto se posiciona al final
37.- Acceder a un control por la tecla rápida sin necesidad de pulsar ALT+letra. (21/Sep) Este "truco" servirá para aquellos forms en los que
necesitemos acceder a distintos controles que tienen una tecla de acceso rápido,
pero sin necesidad de pulsar la combinación de teclas:
Alt+letra_de_acceso. Este código funciona en cualquier versión de Visual Basic, en la versión 1 y 2 no lo he probado... ¿alguien las usa? Sub Form_KeyPress (KeyAscii As Integer)
'Comprobar si la tecla pulsada coincide con
'alguna de acceso rápido
'
'NOTAS:
' Debe estar puesto Option Compare Text
' El KeyPreview del Form debe estar a True
' Esto no es demasiado útil si hay TextBoxes
' ya que no podrás escribir los caracteres
' de acceso rápido
' Pero para cualquier otra aplicación está bien
'
Dim ch As String
Dim i%, j%
'Detectar los errores producidos
'al encontrar controles sin Caption
On Local Error Resume Next
ch = Chr$(KeyAscii)
'Un bucle para todos los controles de este form
For i = 0 To Me.Controls.Count - 1
j = InStr(Me.Controls(i).Caption, "&" & ch)
'Si tiene un código de acceso rápido...
If j Then
'Esto es para que descarte la tecla pulsada
KeyAscii = 0
'Enviamos la pulsación Alt+tecla
SendKeys "%" & ch
'nada más que hacer
Exit For
End If
Next
'Si se ha producido un error...
Err = 0
'restaurar la rutina de detección de errores
On Local Error GoTo 0
End Sub
38.- Para los que tenemos poca memoria... y VB5 (22/Oct) Realmente es una chorradilla de truco, pero lo mismo
a tí no se te había ocurrido... (la verdad es que a mí tampoco...)
39.- Cómo simular sobreescribir e insertar en un TextBox (12/Ene) Este truco está sacado de la Microsoft Knowledge Base - How to Emulate Overtype Mode in a Visual Basic Text Box, ID del Artículo: Q96210, por eso los comentarios los he dejado en inglés. Lo único que yo he añadido es el código del evento Text1_KeyDown para que funcione bien al mover el cursor si estamos en modo INSERT. Este es el código, lo del Label es sólo a título informativo. ¡Que lo disfrutes! Option Explicit
Const MODE_OVERTYPE = "overtype"
Const MODE_INSERT = "insert"
Private Sub Form_Load()
Text1.Tag = MODE_INSERT
Label1.Caption = MODE_INSERT
End Sub
Private Sub Text1_Change()
' You have taken some action that changed the text in the
' text box. Reset the SelLength if you are in overtype mode.
If Text1.Tag = MODE_OVERTYPE And Text1.SelLength = 0 Then
Text1.SelLength = 1
End If
End Sub
Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
'
'Esto es para manejar bien el movimiento del cursor
'
Select Case KeyCode
' Handle keys that move the caret position and reset the
' SelLength if you are in overtype mode:
Case vbKeyLeft, vbKeyRight, vbKeyUp, vbKeyDown, vbKeyHome, vbKeyEnd, vbKeyPageUp, vbKeyPageDown
If Text1.Tag = MODE_OVERTYPE Then
Text1.SelLength = 0
End If
End Select
End Sub
Sub Text1_KeyPress(KeyAscii As Integer)
' If you press BACKSPACE and are in overtype mode,
' then set SelLength to 0 so the backspace will correctly
' delete the character to the left of the current caret
' position. SelLength will be reset when the Text1_Change
' event occurs following the backspace.
If KeyAscii = vbKeyBack And Text1.Tag = MODE_OVERTYPE Then
Text1.SelLength = 0
End If
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
' Toggle between insert and overtype modes.
Case vbKeyInsert
If Text1.Tag = MODE_OVERTYPE Then
Text1.Tag = MODE_INSERT
Label1.Caption = MODE_INSERT
Else
Text1.SelLength = 1
Text1.Tag = MODE_OVERTYPE
Label1.Caption = MODE_OVERTYPE
End If
' Handle keys that move the caret position and reset the
' SelLength if you are in overtype mode:
Case vbKeyLeft, vbKeyRight, vbKeyUp, vbKeyDown, vbKeyHome, vbKeyEnd, vbKeyPageUp, vbKeyPageDown
If Text1.Tag = MODE_OVERTYPE Then
Text1.SelLength = 1
End If
End Select
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
' You have clicked at a new location within the text box. Reset the
' SelLength if you are in overtype mode.
If Text1.Tag = MODE_OVERTYPE And Text1.SelLength = 0 Then
Text1.SelLength = 1
End If
End Sub
40.- Limitar la entrada de un TextBox sólo a números (21/Ene) Este truco es realmente una colaboración de Esteve, el que está con el gato en la foto de los que dan la cara, yo sólo le he "corregido" un pequeño fallillo que tenía el código que eme envió originalmente... Realmente la base del truco es el uso de la función
IsNumeric, el problema que había era que si se introducía un número decimal
menor que 1, había que poner el CERO delante del signo decimal, este caso se
resuelve añadiendo ese CERO al valor que se le pasa a esta función... con lo
cual acepta cualquier número... Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0 'Para que no "pite"
SendKeys "{tab}" 'Envia una pulsación TAB
ElseIf KeyAscii <> 8 Then 'El 8 es la tecla de borrar (backspace)
'Si después de añadirle la tecla actual no es un número...
If Not IsNumeric("0" & Text1.Text & Chr(KeyAscii)) Then
'... se desecha esa tecla y se avisa de que no es correcta
Beep
KeyAscii = 0
End If
End If
End Sub
41.- Justificar el contenido de un TextBox (22/Feb) El tema de la justificación del contenido de un
textbox es algo simple de solucionar, para ello se debe asignar a la propiedad
Multiline el valor True, de esta forma la propiedad Alignment funciona
correctamente. 42.- Mostrar los elementos de un ComboBox mientra se escribe (4/Abr) Esto no es nada nuevo, pero es una ampliación de un
truco anterior y de una de las colaboraciones. Escribe el siguiente código en el form que contenga el Combo: Private Sub Combo1_Change(Index As Integer)
Static YaEstoy As Boolean
On Local Error Resume Next
If Not YaEstoy Then
YaEstoy = True
unCombo_Change Combo1(Index).Text, Combo1(Index)
YaEstoy = False
End If
Err = 0
End Sub
Private Sub Combo1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
unCombo_KeyDown KeyCode
End Sub
Private Sub Combo1_KeyPress(Index As Integer, KeyAscii As Integer)
unCombo_KeyPress KeyAscii
End Sub
Añade estas declaraciones y procedimientos en un
módulo BAS, Option Explicit
Dim Combo1Borrado As Boolean
Public Sub unCombo_KeyDown(KeyCode As Integer)
If KeyCode = vbKeyDelete Then
Combo1Borrado = True
Else
Combo1Borrado = False
End If
End Sub
Public Sub unCombo_KeyPress(KeyAscii As Integer)
'si se pulsa Borrar... ignorar la búsqueda al cambiar
If KeyAscii = vbKeyBack Then
Combo1Borrado = True
Else
Combo1Borrado = False
End If
End Sub
Public Sub unCombo_Change(ByVal sText As String, elCombo As ComboBox)
Dim i As Integer, L As Integer
If Not Combo1Borrado Then
L = Len(sText)
With elCombo
For i = 0 To .ListCount - 1
If StrComp(sText, Left$(.List(i), L), 1) = 0 Then
.ListIndex = i
.Text = .List(.ListIndex)
.SelStart = L
.SelLength = Len(.Text) - .SelStart
Exit For
End If
Next
End With
End If
End Sub
43.- Activar la instancia anterior de una aplicación al cargarla por segunda vez (15/May) Cuando se ejecuta una aplicación de Visual Basic, se
puede saber, mediante la propiedad PrevInstance del objeto App, si dicha
aplicación se está ejecutando. He de aclarar que este truco sólo sirve si el Caption
del programa es siempre el mismo. Vamos ya con el código para hacer eso de activar la aplicación que se está ejecutando. Private Sub Form_Load()
Dim sCaption As String
'si ya se está ejecutando
If App.PrevInstance Then
'Guardar el caption de esta aplicación
sCaption = Caption
'Cambiar el caption actual para que no se active esta
Caption = "cualquier cosa"
'Activar la otra instancia
AppActivate sCaption
'Terminar esta copia del programa
End
End If
'Continuar ya que no hay otra copia
End Sub
Esto es lo que habría que hacer si el caption de la
aplicación cambia y no mantiene siempre el mísmo valor. Private Sub Form_Load()
Dim sCaption As String
'si ya se está ejecutando
If App.PrevInstance Then
'Leer del fichero de configuración el caption de la aplicación
sCaption = GetSetting("Aplicacion.ini", "General", "Caption", Caption)
'Cambiar el caption actual para que no se active esta
Caption = "cualquier cosa"
'Activar la otra instancia
AppActivate sCaption
'Terminar esta copia del programa
End
End If
'Cuando se cambie el caption de la aplicación,
'guardarlo en el fichero de configuración
SaveSetting "Aplicacion.ini", "General", "Caption", Caption
End Sub
También se puede usar este método en el caso de que el inicio de la aplicación esté en un procedimiento SUB MAIN, en ese caso no podrás usar la propiedad Caption en la asignación de sCaption ni es necesario cambiarla para que no se active esta copia, siempre y cuando al iniciarse desde el módulo BAS aún no se haya mostrado el form. 44.- Hacer referencia a un control usando una variable (23/May) Ya sabes que para asignar un valor de una propiedad
de un control debes hacer lo siguiente: Pero puede que te encuentres en la necesidad de hacer
referencia a un control por medio de una variable, por ejemplo en el caso de que
crees una clase que manipule controles pero sólo sabe de ese control el nombre y
nada más. Si el control está dentro de un array de controles,
se tendrá que hacer esto: Esta forma de usar los controles, la tuve que usar en una clase que manipulaba unas etiquetas y unos contenedores, para no obligarme a usar siempre el mismo nombre en las etiquetas y contenedores. 45.- Otra procedimiento para esperar X segundos (28/Ago) Pues eso, otra forma de esperar un número determinado de segundos. 'Si se quiere usar de forma GLOBAL, insertarlo en un Módulo BAS y declararlo como público
Private Sub Wait(ByVal nSec As Integer)
'Esperar un número de segundos
Dim t1 As Date, t2 As Date
t1 = Second(Now)
t2 = t1 + nSec
Do
DoEvents
Loop While t2 > Second(Now)
End Sub
46.- Más sobre la colección Forms y Controls (hacer referencia a un control o form usando variables) (11/Oct) Esto es una ampliación/aclaración sobre el Tip 11, y viene a cuento por unas pruebas hechas en una consulta recibida, que por cierto, se me quedó, como muchas otras en el tintero... La cuestión es la siguiente: Según el Tip 11, se puede referenciar a una propiedad de un control de la
siguiente forma: '
Dim tControl As Control
Set tControl = Controls(sNombreControl)
tControl.BackColor = 0&
Por tanto, se supone que se debería poder hacer esto
otro para poder modificar esa misma
propiedad: '
Dim tForm As Form
Set tForm = Forms(sNombreForm)
tForm.BackColor = vbRed
Pues no... al menos a mi no me ha funcionado... me da
Type Mismatch (error 13) La solución que he encontrado para hacer esto es la
siguiente: '
Public Sub Propiedades(ByVal elForm As String, _
ByVal elControl As String, _
ByVal laPropiedad As String, _
ByVal elValor As Variant) 'Los parámetros se indican como cadena de caracteres,
'salvo el último que indica el valor a asignar
Dim tmpForm As Form
Dim tForm As Form
Dim tControl As Control
'Recorremos la colección Forms en busca del form indicado
For Each tmpForm In Forms
'Si es el mismo nombre, este es el form que queremos
If tmpForm.Name = elForm Then
'Asignarlo a la variable
Set tForm = tmpForm
End If
Next
'Si no se ha encontrado ese form, avisarlo mediante un error
If tForm Is Nothing Then
Err.Raise vbObjectError + 1000, _
"Propiedades", _
"No se ha hallado el form indicado por " & elForm
Else
'Para detectar el error de asignación del control
On Local Error Resume Next
'Asignamos el control deseado a la variable
Set tControl = tForm.Controls(elControl)
If Err Then
Err = 0
'No atrapar los errores, sino no se mostraría el nuestro...
On Local Error GoTo 0
Err.Raise vbObjectError + 1000, _
"Propiedades", _
"No se ha hallado el control indicado por " & elControl & _
" en el form " & elForm
End If
'interceptamos las propiedades que podemos manipular
'si se deja esto de LCase(laPropiedad), los nombres deben estar en minúsculas
'También puedes usar Option Compare Text en el módulo.
Select Case LCase(laPropiedad)
Case "backcolor"
tControl.BackColor = elValor
Case "forecolor"
tControl.ForeColor = elValor
Case "caption"
tControl.Caption = elValor
Case "text"
tControl.Text = elValor
Case Else
'etc.
End Select
'
'En VB6 se puede usar CallByName para asignar el valor de una propiedad:
'evitandote todo el mogollón de comparaciones...
'CallByName tControl, laPropiedad, VbLet, elValor
'
End If
End Sub
'Para usarlo:
Propiedades Me.Name, "Label1", "Caption", "Hola Mundo"
En resumen: si se quiere obtener un "objeto" form usando Forms("nombre del form"), no se puede... |