Como
aumentar el Tamaño de un RichTextBox en Ejecución (y cualquier TextBox,
Picture, etc.)
Private Sub Form_Resize()
If Not Me.WindowState = vbMinimized Then RichTextBox1.Move 0, 0, Me.Width - 100,
Me.Height - 400
End If
End Sub
Despliegue
Automático de un ComboBox al recibir el Foco...
En primer
lugar, debes declarar la funcion en un modulo BAS:
Declare Function SendMessage Lib "user32" Alias
"SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _lParam As Long)
As Long
Y escribe
este código en el evento GotFocus del control ComboBox:
Sub Combo1_GotFocus()
Const CB_SHOWDROPDOWN = &H14F
Dim Tmp
Tmp = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
End Sub
CheckBox en DBGrid...
El Grid
tiene una propiedad Columns que hace referencia a la columna encuestion. La
columna
tiene otro objeto ValueItems que determina el aspecto de la columna. La
propiedad Presentation
de este objeto determina el modo de presentación. El valor 4 representa a un
checkbox.
TDbGrid1.Columns(1).ValueItems.Presentation = 4
Detectar
si cambia el contenido de un Control TextBox
Solamente
necesitamos un control TextBox y declarar en un Modulo lo siguiente:
Declare Function SendMessage Lib "user32"
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
(Ojo,
toda esta declaracion debe estar en una sola linea!!)
En el
Evento Click del Form1 colocar lo siguiente:
Sub Form_Click()
If SendMessage(Text1.hWnd, &HB8, 0, ByVal 0&) = 1
then
Form1.Caption = "Se ha cambiado
el Texto"
Else
Form1.Caption = "Se ha dejado
igual el Texto"
End If
End Sub
Una
ventana con forma ELIPTICA !!!???
Solamente
necesitamos declarar en un Modulo lo siguiente:
Public Declare Function SetWindowRgn Lib
"user32" Alias "SetWindowRgn" (ByVal hWnd As Long, _
ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateEllipticRgn Lib "gdi32" Alias
"CreateEllipticRgn" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
En el
evento click de la ventana:
Private
Sub Form_Click()
Dim Xs as Long, Ys as Long
Xs = Me.Width / Screen.TwipsPerPixelX
Ys = Me.Height /
Screen.TwipsPerPixelY
SetWindowRgn hWnd, CreateEllipticRng(0, 0, Xs, Ys), True
End Sub
Utilización
de los controles DirListBox, DriveListBox y FileListBox
Para ver el funcionamiento de este pequeño visor de iconos necesitamos colocar
en un
Form1 (default) los siguientes controles:
El
Codigo a colocar es el siguiente:
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_Click()
Picture1.Picture = LoadPicture(Dir1.Path & "/" &
File1.FileName)
Label1.Caption = "Icono Seleccionado: " & UCase$(File1.FilaName)
End Sub
Private Sub File1_PathChange()
File1.FileName = "*.ICO"
End Sub
El método ARRANGE
El método ARRANGE se aplica (casi
exclusivamente) en los formularios MDI, ya que es utilizado para ordenar de
diversas formas los iconos y las ventanas abiertas.
Este método es el aplicado en un
item de menú que (habitualmente) llamamos Ventana, donde, por ejemplo
colocaremos como sub-items lo siguiente: Cascada, Mosaico Vertical, Mosaico
Horizontal y Organizar Iconos.
El código para la ejecución se
coloca en los eventos CLICK de cada item.
Ejemplo:
Private Sub Organizar_Iconos_Click()
MDIForm.Arrange 3
End Sub
Private Sub
Mosaico_Vertical_Click()
MDIForm.Arrange 2
End Sub
Private Sub
Mosaico_Horizontal_Click()
MDIForm.Arrange 1
End Sub
Private Sub Cascada_Click()
MDIForm.Arrange 0
End Sub
Un sencillo Cronómetro
Para ejecutar un lapso de tiempo x (por
ejemplo 5 segundos), escribir el siguiente codigo en un Modulo Nuevo:
Public Sub
Esperar(Tiempo as Single)
Dim ComienzoTiempo as Single
Dim FinTiempo as Single
ComienzoTiempo = Timer
FinTiempo = ComienzoTiempo + Tiempo
Do While FinTiempo > Timer
Do Events
If ComienzoTiempo > Timer Then
FinTiempo = FinTiempo - 24 * 60 * 60
End If
Loop
End Sub
Para "llamarlo" desde un Form comun, colocar (por ejemplo, en el
evento Click)
Esperar(5)
Eliminar el "Beep" al
pasar el foco de un TextBox a otro control...
Insertar el siguiente Codigo en el evento KeyPress de un TextBox de nuestro
Formulario:
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Or KeyAscii = 9 Then KeyAscii = 0
End Sub
Situar el Cursor en un Control
determinado
Para situar el cursor encima de un
control determinado, por ejemplo un Botón, situar el siguiente codigo en un
Modulo:
Declare sub SetCursorPos Lib "User32" (ByVal X as Integer, ByVal Y as
Integer)
Insertar en siguiente código en el evento Load de el Form:
Private Sub Form1_Load()
X % =
(Form1.Left + Command1.Left + Command1.Width / 2 + 60 ) / Screen.Twips
Y% =
(Form1.Top + Command1.Top + Command1.Height / 2 + 360) / Screen.Twips
SetCursorPos
X%, Y%
End Sub
Nota: Para que sea mas fácil la escritura
del codigo a colocar en el modulo, Visual Basic trae el Visor de API de Windows
Mostrar / Ocultar el puntero del
Mouse
Insertar el siguiente Codigo en los
eventos Click de dos botones en nuestro Form
Private
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private
Sub cmdOcultar_Click()
resultado = ShowCursor(False)
End Sub
Private Sub cmbMostrar_Click()
resultado = ShowCursor(True)
End Sub
Pasar de un control a otro con
"Enter"
Cambiar la Propiedad KeyPreview del
control TextBox a True e inserte el siguiente Codigo en el evento KeyPress del
Form:
Private
Declare Sub Form1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Provocar la Transparencia de un
Form
Insertar el siguiente Codigo en un Modulo:
Declare
Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Nota: Debe estar todo en una sola linea
(Usar el Visor de Texto API, que viene con Visual Basic)
Insertar el siguiente Codigo en
CommandButton para probar:
Private Sub
Command1_Click()
Dim Resp As Long
Resp = SetWindowLong(Me.hWnd, -20, &H20&)
Form1.Refresh
End Sub
Arreglo sugerido por Esteban:
En un módulo:
Declare Function SetWindowLong Lib "user32"
Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long,
ByVal dwNewLong As Long) As Long
Public Const WS_EX_TRANSPARENT = &H20&
Public Const GWL_HINSTANCE = (-6)
Public Const GWL_EXSTYLE = (-20)
Public Const GWL_HWNDPARENT = (-8)
Public Const GWL_ID = (-12)
Public Const GWL_STYLE = (-16)
Public Const GWL_USERDATA = (-21)
Public Const GWL_WNDPROC = (-4)
y en el Form_Load
Call
SetWindowLong(Form1.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT)
Gracias, Esteban!
Centrar una Ventana
Para Centrar una ventana en el medio de la
pantalla, colocar el siguiente codigo en el evento Load de un Form:
Me.Move
(Sreen.Width - Me.Width) / 2, Me.Move (Screen.Height - Me.Height) / 2
Presentar una pantalla Acerca de...
por defecto (1):
Private
Declare Function ShellAbout Lib "shell32.dll" Alias _
"ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, _
ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Sub
Command1_Click()
Call ShellAbout(Me.hwnd, "Mi Programa", "Copyright 1999,
PMMF", Me.Icon)
End Sub
Utilizando el Control Graph
Primero rellenas las etiquetas del graph,
es decir, lo que es la "leyenda", y pones a 0
los datos del Graph (de paso)
' Muchos cajeros, un sólo dato.
grafico_frm.grafico.ColumnCount
= (Len(x2) - 1) / 3
ReDim label_y(1 To grafico_frm.grafico.ColumnCount)
' Toma nota de las etiquetas (y)
i = 1
For i1 = 0 To lista_cajeros.ListCount - 1
If lista_cajeros.Selected(i1) Then
label_y(i) = lista_cajeros.List(i1)
' Nombre de las
leyendas
grafico_frm.grafico.Column = i
grafico_frm.grafico.ColumnLabel =
label_y(i)
i = i + 1
If i =
(grafico_frm.grafico.ColumnCount + 1) Then
Exit For
End If
End If
Next i1
For i1 = 0
To lista_datos.ListCount - 1
If lista_datos.Selected(i1) Then
x = "'" +
lista_datos.List(i1) + "'"
Exit For
End If
Next i1 ' Después, rellenas los datos.
For i1 = 1 To grafico_frm.grafico.RowCount
For i2 = 1 To grafico_frm.grafico.ColumnCount
grafico_frm.grafico.Row = i1
grafico_frm.grafico.Column = i2
grid.row=i1
grid.col=i2
grafico_frm.grafico.Data = val(grid.text)
Next i2
Next i1
(Esperemos que este ejemplo funcione,
jeje)
Imprimir el Grafico Resultante del
Ejemplo Anterior (Con el Control GRAPH)
Printer.PaintPicture picture1.picture,
PosicionVertical, PosicionHorizontal
Printer.EndDoc 'Envia los datos a la impresora
Enviar Faxes Utilizando los
controles de VB
Utilizaremos para ello los controles MAPI
Messages y MAPI Session para crear un mensaje de Exchange.
Si en el campo de la dirección e-mail empiezas por "Fax: " y
continuas con el nº de fax, conseguirás enviar el mensaje a través del
servicio MS Fax.
Ten cuidado de utilizar un perfil de
Exchange que solo incluya el servicio Fax, no el Internet Mail, porque si no
intentará enviarlo por los dos sistemas.
MAPISession1.LogonUI = False
wPerfil = "Configuraciones de MS Exchange"
MAPISession1.UserName = wPerfil
MAPISession1.SignOn
MAPIMessages1.SessionID = MAPISession1.SessionID
Sesion = True
lblEstado = "Creando mensaje..."
MAPIMessages1.ComposeMAPIMessages1.MsgSubject = ""
' No utilizar el campo de texto. Lo intenta imprimir con el Word como
' segunda hoja y falla dando error WordBasic nº 124 (teniendo instalado el
Parche)
MAPIMessages1.MsgNoteText = "Este es el texto de la prueba....."
MAPIMessages1.RecipIndex = 0
MAPIMessages1.RecipIndex = NumDestino
MAPIMessages1.RecipType = mapToList
MAPIMessages1.RecipDisplayName = Data1.Recordset.Fields(1)
MAPIMessages1.RecipAddress = "Fax:" & Data1.Recordset.Fields(0)
MAPIMessages1.AttachmentIndex = I
MAPIMessages1.AttachmentPosition = I
MAPIMessages1.AttachmentPathName = wPath
MAPIMessages1.AttachmentName = wName
lblEstado = "Enviando mensaje..."
MAPIMessages1.Send
MAPISession1.SignOff
Un Reporte de CrystalReport en una
Ventana??
Dim Frm As
Form
Set Frm = New Form1
CrystalReport1.Destination = crptToWindow
CrystalReport1.WindowParentHandle = Form1.hwnd
CrystalReport1.Action = 1Siendo el Form1 MDI.
El uso del Menu Edicion en tiempo
de Ejecucion
En un Modulo aparte (o bien dentro de las
declaraciones Generales del Form donde vamos a invocarlo)
Declare
Function GetActiveWindow Lib "user32" Alias
"GetActiveWindow" () As Long
Luego esta porcion de codigo la colocamos
en el MDIForm (donde tenemos el Menu Edicion... por ejemplo)
' en el caso de que tenga 2 formularios
' como se cual estoy ocupando ?
' .... de esta manera:
' reviso el primer formulario
If Form1.hWnd = GetActiveWindow Then
.... ' hace esto
End If
' reviso el segundo formulario
If form2.hWnd = GetActiveWindow Then
.... ' hace esto otro
End If
Encriptacion
XOR
El
operador lógico XOR suministra un interesante algoritmo de encriptación, se
codifica en la primera llamada y se decodifica en la segunda. Ejemplo:
Private Sub Form_Load()
Dim s As String
s = "Hola!"
'//Codifica
XORStringEncrypt s, "MiClave"
Show
Print "Codificado: "; s
'//Decodifica
XORStringEncrypt s, "MiClave"
Print "Decodificado: "; s
End Sub
Private Sub XORStringEncrypt(s As String, PassWord As String)
Dim n As Long
Dim i As Long
Dim Char As Long
n = Len(PassWord)
For i = 1 To Len(s)
Char = Asc(Mid$(PassWord, (i Mod n) - n * ((i Mod n) = 0), 1))
Mid$(s, i, 1) = Chr$(Asc(Mid$(s, i, 1)) Xor Char)
Next
End Sub
Leer
una Cadena (string) dentro de otra...
En particular existen muchos comando tales conmo:
CommandString="Source=File.txt;Path=C:\CommonFiles;Title=;..."
Resulta
que deseamos obtener lo que corresponde a Path= de la cadena anterior. La
siguiente función se usa de esta manera: s = GetSubString(CommandString,
"Path=", ";")
Public Function GetSubString( _
s As String, _
StartDelim As String, _
EndDelim As String _
) As String
Dim nStartDelim As Long
Dim nEndDelim As Long
nStartDelim = InStr(s, StartDelim)
If nStartDelim Then
nStartDelim = nStartDelim + Len(StartDelim)
nEndDelim = InStr(nStartDelim, s, EndDelim)
If nEndDelim Then
GetSubString = Mid$(s, nStartDelim, nEndDelim - nStartDelim)
End If
End If
End Function
En el siguiente ejemplo, obtengo el nombre de la base de datos de un
DataEnvirnment
Dim DE As New dePPDMMirror
gsDatabaseConnection = DE.cnnPPDMMirror.ConnectionString
gsDatabaseName = GetSubString(gsDatabaseConnection, "Source=",
";")
Set DE = Nothing
Fecha
aleatoria
A veces
es útil, generalmente para pruebas, generar una fecha aleatoria dentro de un
rango, p.e deseo una fecha entre el 1/1/1960 y 1/1/2000, llamariamos a esta
función como MyDate=GetRandomDate("1/1/1960", "1/1/2000")
Private Function GetRandomDate(ByVal StartDate As Date,
ByVal EndDate As Date) As Date
Static AnotherCall As Boolean
Dim nDays As Single
On Error GoTo ErrorHandler
If Not AnotherCall Then
Randomize Timer
AnotherCall = True
End If
nDays = DateValue(EndDate) - DateValue(StartDate)
GetRandomDate = CDate(DateValue(StartDate) + nDays * Rnd())
Exit Function
ErrorHandler:
GetRandomDate = Null
End Function
Generar
un nombre de archivo aleatorio
La
siguiente función genera un nombre de archivo aleatorio. Puede ser utile cuando
se requieren archivos temporales.
Private Function GenerateRandomFileName() As String
Const MASKNUM As String = "_0123456789"
Const MASKCHR As String = "abcdefghijklmnoprstuvwxyz"
Const MASK As String = MASKCHR + MASKNUM
Const MINLEN As Integer = 4
Const MAXLEN As Integer = 12
Dim nMask As Long
Dim nFile As Long
Dim sFile As String
Dim sExt As String
Dim i As Long
Dim nChr As Long
nFile = MINLEN + (MAXLEN - MINLEN) * Rnd()
nMask = Len(MASK)
For i = 1 To nFile
nChr = Int(nMask * Rnd()) + 1
sFile = sFile + Mid$(MASK, nChr, 1)
Next
nMask = Len(MASKCHR)
For i = 1 To 3
nChr = Int(nMask * Rnd()) + 1
sExt = sExt + Mid$(MASKCHR, nChr, 1)
Next
GenerateRandomFileName = sFile + "." + sExt
End Function
NOTAS
1) La función asume que la semilla de aleatorios fue iniciada previamente (para
más informacion, ver "Randomize")
2) Puede
obtener el nombre del archivo de temporales de Windows de la siguiente expresión:
TempPath = Environ("TEMP") & "\"
Trasnformar
una Hora a Decimal (y viceversa...)
En
algunos cálculos es requerido transformar datos de hora a decimal y viceversa
(en Topografía es útil). P.e. la hora 10:30 AM será 10.5 en decimal.
Public Function HourDec(h As Variant) As Variant
If Not IsNull(h) Then
HourDec = Hour(h) + Minute(h) / 60 + Second(h) / 3600
End If
End Function
Public Function DecHour(h As Variant) As Variant
Dim nHour As Integer
Dim nMinutes As Integer
Dim nSeconds As Integer
nHour = Int(h)
nMinutes = Int((h - nHour) * 60)
nSeconds = Int(((h - nHour) * 60 - nMinutes) * 60)
DecHour = nHour & ":" & nMinutes & ":" &
nSeconds
End Function
Ejemplo:
Private Sub Command1_Click()
Dim h As Single
Dim d As String
Cls
d = "10:37:58"
h = HourDec(d)
Print "Hora Decimal = "; d
Print "Hora Estándar = "; h
Print "Hora de Decimal a Estándar = "; DecHour(h)
End Sub
El parámetro
de HourDec puede ser un dato Date, expresión que retorne Date
(por ejemplo la función Now), o una cadena, "hh:mm:ss" como en
ejemplo.
Incremento
continuo
Desafortunadamente
Visual Basic no tiene operador de incrementación continua, es decir el famoso
i++ del lenguaje C. Podamos simular algo parecido:
Public Static Function Plus(Optional Start As Variant)
As Long
Dim i As Long
If Not IsMissing(Start) Then
i = Start-1
End If
i = i + 1
Plus = i
End Function
Esta
pequeña función puede ser extremadamente útil en código para obtener
recursos, digamos que es común:
Dim I As Long
I=100
Caption = LoadResString(I)
lblPINCode = LoadResString(1 + I)
fraAccount = LoadResString(2 + I)
optChecking.Caption = LoadResString(3 + I)
optSavings.Caption = LoadResString(4 + I)
...
cmdOK.Caption = LoadResString(n + I)
Supongamos
que hacemos un cambio en el archivo recursos : lblPINCode ya no se usa en el
formulario, y compilamos el recurso. Para actualizar el código tendremos
que ir línea por línea para actualizar el I + x. - Nada práctico.
Mientras que si escribimos:
Caption = LoadResString(Plus(100))
lblPINCode = LoadResString(Plus)
fraAccount = LoadResString(Plus)
optChecking.Caption = LoadResString(Plus)
optSavings.Caption = LoadResString(Plus)
...
cmdOK.Caption = LoadResString(Plus)
La
actualización mensionada consistirá solo en eliminar la línea: lblPINCode
= LoadResString(PlusI). Mejor imposible
Crear
Cadenas Multineas de manera practica
Pienso
que todos nos hemos hartado de escribir s = s + "algo"& vbCrLf
& _ ... etc. La siguiente función es una alternativa simple de crear
cadenas multiline:
Public Function StrChain(ParamArray v() As Variant) As
String
Dim i As Integer
Dim n As Integer
Dim rtn As String
n = UBound(v)
For i = 0 To n
rtn = rtn & v(i)
If i < n Then
rtn = rtn & vbCrLf
End If
Next
StrChain = rtn
End Function
P.e:
Text1 =
StrChain( _
"Hola", _
"cómo", _
"estas")
O
simplemente Text1 = StrChain( "Hola", "cómo",
"estas"), es más cómodo que:
Text1 =
"Hola"& vbCrLf & "cómo" & VbCrLf
& "estas"
Claro,
suponiendo que las cadenas concatenadas sean extensas, como un SQL o un comando
Script.
Saber
si un archivo es binario o solo texto
Algunos
archivos tienen extensiones personalizadas y algunas veces debemos evaluar si
son
o no binarios antes de procesarlos.
Public Function IsBinaryFile(File As String) As Boolean
Const aLf = 10, aCR = 13, aSP = 32
Const MaxRead = 2 ^ 15 - 1
Dim ff As Integer
Dim s As Integer
Dim i As Integer
Dim n As Integer
Dim Rtn As Boolean
On Error GoTo IsBinaryFile_Err
ff = FreeFile
Open File For Binary Access Read As #ff
n = IIf(LOF(ff) > MaxRead, MaxRead - 1, LOF(ff))
Do
i = i + 1
If i >= n Then
IsBinaryFile = False
Rtn = True
Else
s = Asc(Input$(1, #ff))
If s >= aSP Then
Else
If s = aCR Or s = aLf Then
Else
IsBinaryFile = True
Rtn = True
End If
End If
End If
Loop Until Rtn
Close ff
Exit Function
IsBinaryFile_Err:
If ff Then Close ff
MsgBox "Error verifying file " & File & vbCrLf &
Err.Description
End Function
Simplemente
pase el nombre del archivo al argumento y la función retornata un valor bolean.
Por ejemplo MsgBox "¿ Es binario Command.Com ? ... " & IsBinaryFile("command.com").
Estimar
el tiempo de proceso
Esta es
una vieja técnica que emplean para estimar la duración de un bloque de código
o proceso. Es útil para comparar el tiempo de dos o más algoritmos diferentes
que resuelven un mismo problema.
Dim t As
Single
DoEvents
t = Timer
'// Proceso
...
MsgBox "Elapse time = " & Format(Timer - t, "0.00")
Se
redondea a dos decimales porque las milésimas de segundo son insignificantes.
Debiera ejecutarse dos o tres veces para un estimado más preciso. Por supuesto,
existen técnicas más precisas para evaluación de tiempos, pero esta suele ser
aceptable.
Como
saber si mi form esta abierto...
El
procedimiento IsLoadForm retorna un bolean que indica si el formulario
solicitado por su nombre se encuentra abierto. Opcionalmente se puede hacer
activo si se encuentra en memoria. La función es útil en interfaces MDI.
Public Function IsLoadForm(ByVal FormCaption As String,
Optional Active As Variant) As Boolean
Dim rtn As Integer, i As Integer
rtn = False
Name = LCase(FormCaption)
Do Until i > Forms.Count - 1 Or rtn
If LCase(Forms(i).Caption) = FormCaption Then rtn = True
i = i + 1
Loop
If rtn Then
If Not IsMissing(Active) Then
If Active Then
Forms(i -
1).WindowState = vbNormal
End If
End If
End If
IsLoadForm = rtn
End Function
En
programas que ejecutan una tarea larga, me gusta agregar un texto de información
al usuario a medida que las tareas se van ejecutando (al etilo de Autocad). La
sigueinte técnica fuerza que el texto se muestre continuamente. Use un TextBox Multiline con barras Scroll y nombre
txtReport.
'//API - en un modulo aparte...
Private Declare Function SendMessageByVal Lib "user32" Alias
"SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Private Const EM_LINESCROLL As Long = &HB6
Private Const EM_GETLINECOUNT As Long = &HBA
Private Sub Echo(Optional s As String = "")
Static n As Long
On Error Resume Next
With txtReport
If Len(.Text) Then .Text = .Text & vbCrLf
.Text = .Text & s
'//To end of line (with API)
n = SendMessageByVal(.hWnd, EM_GETLINECOUNT, 0, 0)
SendMessageByVal .hWnd, EM_LINESCROLL, 0, n
DoEvents
End With
End Sub
NOTAS
1. Podría usar la línea SendKeys "^{END}", True pero produce un
efecto colateral en Windows98 (la barra de las ventana pierde su color)
2. Si desea situar el cursor al final del texto use: txtReport.SelStart =
Len(txtReport.Text)
Como
contar los caracteres de una cadena...
Option
Explicit
Function Cuantos(Inicio, Cadena As String, Caracter As String)
Dim Resultado, sCuantos
sCuantos = 0 'Inicializa la suma
'evita que entre si no hay nada que
buscar
If IsNull(Cadena) Or IsNull(Caracter) Or Len(Cadena) = 0 Or
Len(Caracter)= 0 Then Exit Function
Resultado = InStr(Inicio, Cadena,
Caracter) 'localiza la 1ª coincidencia
Do While
Resultado > 0 'y cuenta hasta que termina
sCuantos = sCuantos + 1
Inicio = Resultado + 1
Resultado = InStr(Inicio, Cadena, Caracter)
Loop
Cuantos = sCuantos
End Function
Obligar
a introducir solamente números (I)
Private
Sub txtText1_KeyPress(KeyAscii As Integer)
'solo admitirá dígitos, el punto y la coma
'si se pulsa alguna otra tecla, anulará la pulsación de teclado
If InStr("0123456789.,", Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End Sub
Sub Text1_Keypress(KeyAscii As Integer)
If KeyAscii <> Asc("9") Then
'KeyAscii = 8 es el retroceso o BackSpace
If KeyAscii <> 8 Then
KeyAscii = 0
End If
End If
End Sub
Obligar
a introducir solamente números (II)
Private Sub txtText1_LostFocus()
If IsNumeric(txtText1) = False then
MsgBox "Lo siento. Debe Ingresar SOLAMENTE Números.",vbInformation,"Cuidado!"
txtText1.SetFocus
End If
Convertir
números en texto
Esta función, convierte un número en su correspondiente trascripción a
letras. Funciona bien con
números
enteros y con hasta 2 decimales, pero más de 2 decimales se pierde y no
"sabe" lo que dice.
Debes introducir este código en un módulo (por ejemplo) y realizar la llamada
con el número que
deseas
convertir. Por Ejemplo: Label1 = Numlet(CCur(Text1))
Option Explicit
Dim Unidades$(9), Decenas$(9), Oncenas$(9)
Dim Veintes$(9), Centenas$(9)
Function Numlet$(NUM#)
Dim DEC$, MILM$, MILL$, MILE$, UNID$
ReDim SALI$(11)
Dim var$, I%, AUX$
'NUM# = Round(NUM#, 2)
var$ = Trim$(Str$(NUM#))
If InStr(var$, ".") = 0 Then
var$ = var$ +
".00"
End If
If
InStr(var$, ".") = Len(var$) - 1 Then
var$ = var$ +
"0"
End If
var$ = String$(15 - Len(LTrim$(var$)), "0") +
LTrim$(var$)
DEC$ = Mid$(var$, 14, 2)
MILM$ = Mid$(var$, 1, 3)
MILL$ = Mid$(var$, 4, 3)
MILE$ = Mid$(var$, 7, 3)
UNID$ = Mid$(var$, 10, 3)
For I% = 1 To 11: SALI$(I%) = " ": Next I%
I% = 0
Unidades$(1) = "UNA "
Unidades$(2) = "DOS "
Unidades$(3) = "TRES "
Unidades$(4) = "CUATRO "
Unidades$(5) = "CINCO "
Unidades$(6) = "SEIS "
Unidades$(7) = "SIETE "
Unidades$(8) = "OCHO "
Unidades$(9) = "NUEVE "
Decenas$(1) = "DIEZ "
Decenas$(2) = "VEINTE "
Decenas$(3) = "TREINTA "
Decenas$(4) = "CUARENTA "
Decenas$(5) = "CINCUENTA "
Decenas$(6) = "SESENTA "
Decenas$(7) = "SETENTA "
Decenas$(8) = "OCHENTA "
Decenas$(9) = "NOVENTA "
Oncenas$(1) = "ONCE "
Oncenas$(2) = "DOCE "
Oncenas$(3) = "TRECE "
Oncenas$(4) = "CATORCE "
Oncenas$(5) = "QUINCE "
Oncenas$(6) = "DIECISEIS "
Oncenas$(7) = "DIECISIETE "
Oncenas$(8) = "DIECIOCHO "
Oncenas$(9) = "DIECINUEVE "
Veintes$(1) = "VEINTIUNA "
Veintes$(2) = "VEINTIDOS "
Veintes$(3) = "VEINTITRES "
Veintes$(4) = "VEINTICUATRO "
Veintes$(5) = "VEINTICINCO "
Veintes$(6) = "VEINTISEIS "
Veintes$(7) = "VEINTISIETE "
Veintes$(8) = "VEINTIOCHO "
Veintes$(9) = "VEINTINUEVE "
Centenas$(1) = " CIENTO "
Centenas$(2) = " DOSCIENTOS "
Centenas$(3) = " TRESCIENTOS "
Centenas$(4) = "CUATROCIENTOS "
Centenas$(5) = " QUINIENTOS "
Centenas$(6) = " SEISCIENTOS "
Centenas$(7) = " SETECIENTOS "
Centenas$(8) = " OCHOCIENTOS "
Centenas$(9) = " NOVECIENTOS "
If NUM# > 999999999999.99 Then Numlet$ = " ":
Exit Function
If Val(MILM$) >= 1 Then
SALI$(2) =
" MIL ": '** MILES DE MILLONES
SALI$(4) =
" MILLONES "
If Val(MILM$) <> 1 Then
Unidades$(1) = "UN "
Veintes$(1) = "VEINTIUN "
SALI$(1) = Descifrar$(Val(MILM$))
End If
End If
If Val(MILL$) >= 1 Then
If Val(MILL$)
< 2 Then
SALI$(3) = "UN ": '*** UN MILLON
If Trim$(SALI$(4)) <> "MILLONES" Then
SALI$(4) = " MILLON "
End If
Else
SALI$(4) = " MILLONES ": '*** VARIOS MILLONES
Unidades$(1) = "UN "
Veintes$(1) = "VEINTIUN "
SALI$(3) = Descifrar$(Val(MILL$))
End If
End If
For I% = 2 To 9
Centenas$(I%) = Mid$(Centenas(I%), 1,
11) + "AS"
Next I%
If Val(MILE$) > 0 Then
SALI$(6) =
" MIL ": '*** MILES
If Val(MILE$) <> 1 Then
SALI$(5) = Descifrar$(Val(MILE$))
End If
End If
Unidades$(1) = "UNA "
Veintes$(1) = "VEINTIUNA"
If Val(UNID$)
>= 1 Then
SALI$(7) = Descifrar$(Val(UNID$)): '*** CIENTOS
If Val(DEC$) >= 10 Then
SALI$(8) = " CON ": '*** DECIMALES
SALI$(10) = Descifrar$(Val(DEC$))
End If
End If
If Val(MILM$)
= 0 And Val(MILL$) = 0 And Val(MILE$) = 0 And Val(UNID$) = 0 Then SALI$(7) =
" CERO "
AUX$ =
""
For I% = 1 To 11
AUX$ = AUX$ + SALI$(I%)
Next I%
Numlet$ = Trim$(AUX$)
End Function
Function Descifrar$(numero%)
Static SAL$(4)
Dim I%, CT As Double, DC As Double, DU As Double, UD As Double
Dim VARIABLE$
For I% = 1 To 4: SAL$(I%) = " ": Next I%
VARIABLE$ = String$(3 -
Len(Trim$(Str$(numero%))), "0") + Trim$(Str$(numero%))
CT = Val(Mid$(VARIABLE$, 1, 1)): '***
CENTENA
DC = Val(Mid$(VARIABLE$, 2, 1)): '***
DECENA
DU = Val(Mid$(VARIABLE$, 2, 2)): '***
DECENA + UNIDAD
UD = Val(Mid$(VARIABLE$, 3, 1)): '***
UNIDAD
If numero% = 100 Then
SAL$(1) =
"CIEN "
Else
If CT
<> 0 Then SAL$(1) = Centenas$(CT)
If DC <> 0 Then
If DU <> 10 And DU <> 20 Then
If DC = 1 Then SAL$(2) = Oncenas$(UD): Descifrar$ = Trim$(SAL$(1) + "
" + SAL$(2)) then
Exit Function
If DC = 2 Then SAL$(2) = Veintes$(UD): Descifrar$ = Trim$(SAL$(1) + "
" + SAL$(2)) then
Exit Function
End If
SAL$(2) = " " + Decenas$(DC)
If UD <> 0 Then SAL$(3) = "Y "
End If
If UD <> 0 Then SAL$(4) = Unidades$(UD)
End If
Descifrar = Trim$(SAL$(1) + SAL$(2) + SAL$(3) + SAL$(4))
End Function
Convertir
números romanos a árabes (no está probado)
Es muy fácil de utilizar, le pasas la cadena con el número en árabe y te
devuelve el número,
necesitas
las dos funciones que tienes a continuación.
Function ConvertirArabe(Romano As String) As Integer
Dim Numero As Integer, Valor1 As Integer, Valor2 As Integer, Cadena As String
If Len(Romano) = 0 Then ConvertirArabe = 0: Exit Function
Cadena = Trim(Romano)
Numero = 0
Do
Valor1 =
VerValor(left(Cadena, 1))
Cadena =
Right$(Cadena, Len(Cadena) - 1)
Valor2 =
VerValor(left(Cadena, 1))
If Valor1 >= Valor2 Then
Numero = Numero + Valor1
Else
Numero = Numero - Valor1
End If
Loop Until Len(Cadena) = 0
ConvertirArabe = Numero
End Function
Function VerValor(Simbolo As String) As Integer
Select Case Simbolo
Case "I"
VerValor = 1
Case "V"
VerValor = 5
Case "X"
VerValor = 10
Case "L"
VerValor = 50
Case "C"
VerValor = 100
Case "D"
VerValor = 500
Case "M"
VerValor = 1000
Case "Q"
VerValor = 5000
Case "H"
VerValor = 10000
End Select
End Function
Convertir números romanos a árabes
-2- (no está probado)
Function Num2Roman(ByVal N As Integer) As String
Const Digits = "IVXLCDM"
Dim i As Integer, Digit As Integer, Temp As String
i = 1
Temp = ""
Do While N > 0
Digit = N Mod 10
N = N \ 10
Select Case Digit
Case 1
Temp =
Mid(Digits, i, 1) & Temp
Case 2
Temp =
Mid(Digits, i, 1) & Mid(Digits, i, 1) & Temp
Case 3
Temp =
Mid(Digits, i, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) & Temp
Case 4
Temp =
Mid(Digits, i, 2) & Temp
Case 5
Temp =
Mid(Digits, i + 1, 1) & Temp
Case 6
Temp =
Mid(Digits, i + 1, 1) & Mid(Digits, i, 1) & Temp
Case 7
Temp =
Mid(Digits, i + 1, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) & Temp
Case 8
Temp =
Mid(Digits, i + 1, 1) & Mid(Digits, i, 1) & Mid(Digits, i, 1) &
Mid(Digits, i, 1) & Temp
Case 9
Temp =
Mid(Digits, i, 1) & Mid(Digits, i + 2, 1) & Temp
End Select
i = i + 2
Loop
Num2Roman = Temp
End Function
Seleccionar
todo el Texto al recibir el Foco
Insertar el siguiente Codigo en el evento GotFocus de un TextBox:
Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLenght = Len(Text1.Text)
End Sub
Convertir
a Mayúsculas/Minúsculas segun vamos escribiendo
Insertar
el siguiente Codigo en el evento Change de un control TextBox
Private Sub Text1_Change()
Dim I as Integer
Text1.Text = UCase(Text1.Text)
I = Len(Text1.Text)
Text1.SelStart(I)
End Sub
Nota: Si
queremos convertir a minusculas, solo hay que cambiar UCase por LCase. Este
codigo convierte a mayusculas/minusculas segun vamos escribiendo.-
Validar
Fechas
Sub
ValidarFecha(Fecha As String, valida As Boolean)
Dim
cadena As Date On Error GoTo error
cadena = Format(Fecha, "dd/mm/yyyy")
If Not IsDate(cadena) Then
MsgBox "Compruebe que ha introducido bien la
fecha.", vbInformation
Exit Sub
End If
If cadena > Date Then
valida = True
GoTo error
Else
valida = False
End If
Exit Sub
error:
MsgBox "La fecha no puede ser posterior a la fecha de hoy.",
vbInformation, "Fecha inválida"
valida = True
Exit Sub
End Sub
Pasar
de Decimal a Binario
Function
DecimalABinario(ByVal valor As Long) As String
' Declaración de variables privadas a la función
Dim mayor As Integer
Dim retorno As String
Dim a As Integer
' Localizamos el mayor exponente
mayor = 0
Do While True
If 2 ^ mayor > valor Then
If mayor > 0 Then
mayor = mayor
- 1
End If
Exit Do
End If
mayor = mayor + 1
Loop
' Calculamos el valor binario
retorno = ""
For a = mayor To 0 Step -1
If valor < (2 ^ a) Then
retorno = retorno & "0"
Else
retorno = retorno & "1"
valor = valor - (2 ^ a)
End If
Next a
DecimalABinario = retorno
End Function
Verificar
si una Ventana "X" está cargada
Private Declare Function FindWindow Lib
"USER32" Alias "FindWindowA" ( _
ByVal lpszClassName As String, ByVal lpszWindow As String) As Long
Llamaremos
la función con un:
If
FindWindow(vbNullString, Caption) Then
'//Esta abierta ventana con titulo Caption
End If
Sirve para ventanas dentro y fuera de la aplicación, es decir, la
usaremos para verificar si un formulario ya a sido cargado o para saber si
CALC.EXE esta abierto. Como un detalle, vbNullString es lo que en C se
conoce como un puntero nulo, estrictamente el parámetro es la clase de la
ventana. También puede ser de utilidad saber que FindWindow retorna el
manejador hWnd si la ventana esta abierta.
Inhabilitar
por un ratito los botones de la barra Inicio:
Los eventos Resize suelen tener ejecución asíncrona. Cuando un formulario
utiliza controles ActiveX complejos (léase acceso a datos) que toman acciones
de redimensionamiento, pueden fallar si el usuario, por ejemplo, maximiza la
ventana antes de que termine de cargarse el formulario, o situaciones similares.
La siguiente técnica permite evitar este efecto.
'//Protect while loading
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 GetWindowLong Lib "user32" Alias
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
Public Sub EnabledToolBoxMenu(frm As Form, Action As Boolean)
Static rtn, rtnI
If Action Then
If rtnI Then
rtn = SetWindowLong(frm.hwnd, GWL_STYLE, rtnI)
End If
Else
rtnI = GetWindowLong(frm.hwnd, GWL_STYLE)
rtn = rtnI And Not (WS_SYSMENU)
rtn = SetWindowLong(frm.hwnd, GWL_STYLE, rtn)
End If
End Sub
La forma
correcta de usar el procedimiento es la siguiente:
Private Loading
Private Sub Form_Load()
Loading=True
'//Código de carga...
Loading=False
EnabledToolBoxMenu Me, True
End Sub
Private Sub Form_Activate()
If Loading Then
EnabledToolBoxMenu Me, False
End If
End Sub
NOTA. Se
pueden inhabilitar / habilitar separadamente los bótones. API suministra otras
constantes similares a WS_SYSMENU. Ver documentación de SetWindowLong.
Ocultar
el Puntero del Mouse
Para
este ejemplo agregue un Timer a un formulario y fije la propiedad Interval a
3000. Cada 3 segundos se ocultará el Mouse.
Private Declare Function ShowCursor Lib
"user32" (ByVal bShow As Long) As Long
Private Sub Timer1_Timer()
Static HideMouse As Boolean
HideMouse = Not HideMouse
ShowCursor HideMouse
End Sub
NOTA. No
esta garantizado que ShowCursor produzca el efecto deseado.
Ejecutar
un programa DOS desde VB
Private Sub Command1_Click()
Shell "C:\WINDOWS\COMMAND\EDIT.COM", vbNormalFocus
End Sub
Una
unica instancia de la aplicacion corriendo a la vez...
En el Sub
Main() o en el Form_Load del 1er frm que cargues:
If
App.Previnstance Then
MsgBox "La aplicacion solicitada ya se esta ejecutando"
'Pon aqui el codigo para salir del programa
'(Unload de los formularios cargados, set .. = nothing, etc.)
End
End If
Ejecutar
Microsoft Word desde VB
Hay que
hacer automatización, o sea, instanciar un objeto Word
Dim oWord
as new Word.ApplicationoWord.Visible = True 'Si quieres abrir un documento en
blanco o uno concreto
oWord.Documents.Add
oWord.Documents.Open "<Path\Nombre del documento>"
Bloquear
el Boton Inicio, Crtl + Tab y Ctrl + Alt + Supr
Declarar
en un Módulo lo siguiente:
Public Declare Function SystemParametersInfo Lib
"user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal
fuWinIni As Long) As Long
(Ojo,
toda esta declaracion debe estar en una sola linea!!)
En el
Evento Click del Form1 colocar lo siguiente:
Sub Form_Click()
Dim blnOld as Boolean
If MsgBox ("Desea Bloquear ahora?", vbInformation +
vbYesNo, "Bloqueo") = vbYes then
SystemParametersInfo 97&, True,
blnOld, 0&
Else
SystemParametersInfo 97&, False,
blnOld, 0&
End If
End Sub
Activar/Desactivar
el Bloqueo de Mayusculas
Solamente
necesitamos declarar en un Modulo lo siguiente:
Public Declare Function GetKeyboardState Lib
"user32" Alias "GetKeyboardState" (pbKeyState As Byte) As
Long
Public Declare Function SetKeyboardState Lib "user32" Alias
"SetKeyboardState" (lppbKeyState As Byte) As Long
Public Type KeyboardBytes
kbByte(0 To 255) as Byte
End Type
En el
Evento Click de la ventana (Form) colocaremos el siguiente codigo y nos
fijaremos en la actitud de
la lucecita del Bloqueo de Mayusculas...
Private Sub Form_Click()
Dim kbArray as KeyboardBytes
GetKeyboardState kbArray
kbArray.kbByte(&H14) = IIF(kbArray.kbByte(&H14) = 1,
0, 1)
SetKeyboardState kbArray
End Sub
Cómo
Activar el Protector de Pantallas?
En un
modulo, declarar lo siguiente: