Obtener el nombre de usuario y de la compañia de Windows:
Crear un formulario, añadir dos etiquetas o labels y escribir el siguiente código:
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String,
ByVal lpReserved As Long, lpType As Long, lpData As Any,
lpcbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String,
phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll"
(ByVal hKey As Long) As Long
Private Sub Form_Load()
Dim strUser As String
Dim strOrg As String
Dim lngLen As Long
Dim lngType As Long
Dim hKey As Long
Dim x As Long
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = &H1
x = RegOpenKey(HKEY_LOCAL_MACHINE,
"Software\Microsoft\Windows\CurrentVersion",
hKey) ' open desired key in registry
strUser = Space$(256)
lngLen = Len(strUser)
x = RegQueryValueEx(hKey, "RegisteredOwner",
0, lngType, ByVal strUser, lngLen)
If x = 0 And lngType = REG_SZ And lngLen > 1 Then
strUser = Left$(strUser, lngLen - 1)
Else
strUser = "Unknown"
End If
strOrg = Space$(256)
lngLen = Len(strOrg)
x = RegQueryValueEx(hKey, "RegisteredOrganization", 0, lngType,
ByVal strOrg, lngLen)
If x = 0 And lngType = REG_SZ And lngLen > 1 Then
strOrg = Left$(strOrg, lngLen - 1)
Else
strOrg = "Unknown"
End If
Label1.Caption = "Usuario: " & strUser
Label2.Caption = "Empresa: " & strOrg
x = RegCloseKey(hKey)
End Sub
--------------------------------------------------------------------------------
Forzar a un TextBox para que admita únicamente números:
Crear un formulario, añadir un TextBox y escribir el siguiente código:
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
Nuevo:
Private Sub Text1_Keypress(KeyAscii As Integer)If Not IsNumeric(Chr$(KeyAscii)) And KeyAscii <> 8 Then KeyAscii = 0End Sub
--------------------------------------------------------------------------------
Forzar a un InputBox para que admita únicamente números:
Crear un formulario y escribir el siguiente código:
Private Sub Form_Load()
Dim Numero As String
Do
Numero = InputBox("Introduzca un numero:"
Loop Until IsNumeric(Numero)
MsgBox "El numero es el " & Numero
Unload Me
End Sub
--------------------------------------------------------------------------------
Hacer Drag & Drop de un control (ejemplo de un PictureBox):
En un formulario, añadir un PictureBox con una imagen cualquiera y escribir el siguiente código:
Private DragX As Integer
Private DragY As Integer
Sub Form_DragDrop(Source As Control, X As Single, Y As Single)
Source.Move (X - DragX), (Y - DragY)
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer,
X As Single, Y As Single)
'Si el boton del raton es el derecho, no hacemos nada
If Button = 2 Then Exit Sub
Picture1.Drag 1
DragX = X
DragY = Y
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer,
X As Single, Y As Single)
Picture1.Drag 2
End Sub
--------------------------------------------------------------------------------
Centrar una ventana en Visual Basic:
Usar:
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
En vez de:
Form1.Left = Screen.Width - Width \ 2
Form1.Top = Screen.Height - Height \ 2
--------------------------------------------------------------------------------
Ejecuta pausas durante un determinado espacio de tiempo en segundos:
Llamada: Espera(5)
Sub Espera(Segundos As Single)
Dim ComienzoSeg As Single
Dim FinSeg As Single
ComienzoSeg = Timer
FinSeg = ComienzoSeg + Segundos
Do While FinSeg > Timer
DoEvents
If ComienzoSeg > Timer Then
FinSeg = FinSeg - 24 * 60 * 60
End If
Loop
End Sub
Llamada: pause segundos
Sub Pause(interval)
Dim atime
atime = Timer
Do While Timer - atime < Val(interval)
DoEvents
Loop
End Sub
--------------------------------------------------------------------------------
Editor de texto:
Seleccionar todo el texto:
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
Copiar texto:
Clipboard.Clear
Clipboard.SetText Text1.SelText
Text1.SetFocus
Pegar texto:
Text1.SelText = Clipboard.GetText()
Text1.SetFocus
Cortar texto:
Clipboard.SetText Text1.SelText
Text1.SelText = ""
Text1.SetFocus
Deshacer texto: (Nota: esta operación sólo es eficaz con el control Rich TextBox).
En un módulo copie esta línea:
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal _
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Esta es la instrucción de la función deshacer:
UndoResultado = SendMessage(Text1.hwnd, &HC7, 0&, 0&
If UndoResultado = -1 Then
Beep
MsgBox "Error al intentar recuperar.", 20, "Deshacer texto"
End If
Seleccionar todo el texto:
SendKeys "^A"
Copiar texto:
SendKeys "^C"
Pegar texto:
SendKeys "^V"
Cortar texto:
SendKeys "^X"
Deshacer texto:
SendKeys "^Z"
--------------------------------------------------------------------------------
Obtener el directorio de Windows y el directorio de Sistema:
En un módulo copiar estas líneas:
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA"_
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA"_
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Ponga dos Labels o etiquetas y un botón en el formulario:
Label1, Label2, Command1
Hacer doble click sobre el botón y escribir el código siguiente:
Private Sub Command1_Click()
Dim Car As String * 128
Dim Longitud, Es As Integer
Dim Camino As String
Longitud = 128
Es = GetWindowsDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
Label1.Caption = Camino
Es = GetSystemDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
Label2.Caption = Camino
End Sub
--------------------------------------------------------------------------------
Ocultar la barra de tareas en Windows 95 y/o Windows NT:
En un módulo copiar estas líneas:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName_
As String, ByVal lpWindowName As String) 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
Global Ventana As Long
Global Const Muestra = &H40
Global Const Oculta = &H80
En un formulario ponga dos botones y escriba el código correspondiente
a cada uno de ellos:
'Oculta la barra de tareas
Private Sub Command1_Click()
Ventana = FindWindow("Shell_traywnd", ""
Call SetWindowPos(Ventana, 0, 0, 0, 0, 0, Oculta)
End Sub
'Muestra la barra de tareas
Private Sub Command2_Click()
Call SetWindowPos(Ventana, 0, 0, 0, 0, 0, Muestra)
End Sub
--------------------------------------------------------------------------------
Imprimir el contenido de un TextBox en líneas de X caracteres:
Añadir un TextBox con las propiedades "Multiline=True" y "ScrollBars=Vertical",
y un CommandButton. Hacer doble click sobre él y escribir este código:
Private Sub Command1_Click()
'X es 60 en este ejmplo
imprimeLineas Text1, 60
End Sub
En las declaraciones "Generales" del formulario, escribimos:
Public Sub imprimeLineas(Texto As Object, Linea As Integer)
Dim Bloque As String
'Numero de caracteres = NumC
'Numero de Bloques = NumB
Dim NumC, NumB As Integer
NumC = Len(Texto.Text)
If NumC > Linea Then
NumB = NumC \ Linea
For I = 0 To NumB
Texto.SelStart = (Linea * I)
Texto.SelLength = Linea
Bloque = Texto.SelText
Printer.Print Bloque
Next I
Else
Printer.Print Texto.Text
End If
Printer.EndDoc
End Sub
--------------------------------------------------------------------------------
Leer y escribir un fichero Ini:
Declaraciones generales en un módulo:
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
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
Leer en "Ejemplo.Ini":
Private Sub Form_Load()
Dim I As Integer
Dim Est As String
Est = String$(50, " "
I = GetPrivateProfileString("Ejemplo", "Nombre", "", Est, Len(Est), "Ejemplo.ini"
If I > 0 Then
MsgBox "Tu Nombre es: " & Est
End If
End Sub
Escribir en "Prueba.Ini":
Private Sub Form_Unload(Cancel As Integer)
Dim I As Integer
Dim Est As String
Est = "Ejemplo - Apartado"
I = WritePrivateProfileString("Ejemplo", "Nombre", Est, "Ejemplo.ini"
End Sub
(Nota: si I=0 quiere decir que no existe Información en la línea de fichero Ini a la
que hacemos referencia. El fichero "Ejemplo.Ini" se creará automáticamente).
--------------------------------------------------------------------------------
Crear una barra de estado sin utilizar controles OCX o VBX:
Crear una PictureBox y una HScrollBar:
Propiedades de la HScrollBar:
Max -> 100
Min -> 0
Propiedades de la PictureBox:
DrawMode -> 14 - Merge Pen Not
FillColor -> &H00C00000&
Font -> Verdana, Tahoma, Arial; Negrita; 10
ForeColor -> &H00000000&
ScaleHeight -> 10
ScaleMode -> 0 - User
ScaleWidth -> 100
Insertar en el formulario o módulo el código de la función:
Sub Barra(Tam As Integer)
If Tam > 100 Or Tam <>
Insertar en el evento Change del control HScrollBar:
Private Sub HScroll1_Change()
Barra (HScroll1.Value)
End Sub
En el evento Paint del formulario, escribir:
Private Sub Form_Paint()
Barra (HScroll1.Value)
End Sub
--------------------------------------------------------------------------------
Calcular el espacio total y espacio libre de una Unidad de disco:
Crear un módulo y escribir:
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA"_
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector_
As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Crear 7 Labels:
Escribir el código siguiente:
Private Sub Form_Load()
Dim I1 As Long
Dim I2 As Long
Dim I3 As Long
Dim I4 As Long
Dim Unidad As String
Unidad = "C:/"
GetDiskFreeSpace Unidad, I1, I2, I3, I4
Label1.Caption = Unidad
Label2.Caption = I1 & " Sectores por cluster"
Label3.Caption = I2 & " Bytes por sector"
Label4.Caption = I3 & " Número de clusters libres"
Label5.Caption = I4 & " Número total de clusters"
Label6.Caption = "Espacio total en disco: " & (I1 * I2 * I4)
Label7.Caption = "Espacio libre en disco: " & (I1 * I2 * I3)
End Sub
--------------------------------------------------------------------------------
Crear un efecto Shade al estilo de los programas de instalación:
Crear un proyecto nuevo y escribir el código siguiente:
Private Sub Form_Resize()
Form1.Cls
Form1.AutoRedraw = True
Form1.DrawStyle = 6
Form1.DrawMode = 13
Form1.DrawWidth = 2
Form1.ScaleMode = 3
Form1.ScaleHeight = (256 * 2)
For i = 0 To 255
Form1.Line (0, Y)-(Form1.Width, Y + 2), RGB(0, 0, i), BF
Y = Y + 2
Next i
End Sub
--------------------------------------------------------------------------------
Situar el cursor encima de un determinado control (p. ej.: un botón):
Escribir el código siguiente en el módulo:
Declare Sub SetCursorPos Lib "User32" (ByVal X As Integer, ByVal Y As Integer)
Insertar un botón en el formulario y escribir el siguiente código:
Private Sub Form_Load()
X% = (Form1.Left + Command1.Left + Command1.Width / 2 + 60) / Screen.TwipsPerPixelX
Y% = (Form1.Top + Command1.Top + Command1.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos X%, Y%
End Sub
--------------------------------------------------------------------------------
Menú PopUp en un TextBox:
Ejemplo para no visualizar el menú PopUp implícito de Windows:
En el evento MouseDown del control TextBox escriba:
Private Sub Editor1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then
Editor1.Enabled = False
PopupMenu MiMenu
Editor1.Enabled = True
Editor1.SetFocus
End If
End Sub
--------------------------------------------------------------------------------
Hacer sonar un fichero Wav o Midi:
Insertar el siguiente código en un módulo:
Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Insertar un botón en el formulario y escribir el siguiente código:
Private Sub Command1_Click()
iResult = mciExecute("Play c:\windows\ringin.wav"
End Sub
--------------------------------------------------------------------------------
Hacer un formulario flotante al estilo de Visual Basic:
Crear un nuevo proyecto, insertar un botón al formulario que inserte un formulario más y un módulo.
Pegue el siguiente código en el
módulo:
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Peguar el siguiente código en el formulario principal:
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unload Form2
End Sub
Private Sub Command1_Click()
Dim ret As Integer
If doshow = False Then
ret = SetParent(Form2.hWnd, Form1.hWnd)
Form2.Left = 0
Form2.Top = 0
Form2.Show
doshow = True
Else
Form2.Hide
doshow = False
End If
End Sub
--------------------------------------------------------------------------------
Comprobar si el programa ya está en ejecución:
Crear un nuevo proyecto e insertar el siguiente código:
Private Sub Form_Load()
If App.PrevInstance Then
Msg = App.EXEName & ".EXE" & " ya está en ejecución"
MsgBox Msg, 16, "Aplicación."
End
End If
End Sub
--------------------------------------------------------------------------------
Hallar el nombre del PC en Windows 95 o Windows NT:
Cree un nuevo proyecto e inserte dos ButtonClick y un Módulo:
Pegue el siguiente código en el formulario:
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim nPC as String
Dim buffer As String
Dim estado As Long
buffer = String$(255, " "
estado = GetComputerName(buffer, 255)
If estado <> 0 Then
nPC = Left(buffer, 255)
End If
MsgBox "Nombre del PC: " & nPC
End Sub
Private Sub Command2_Click()
Unload Form1
End Sub
Pegue el siguiente código en el módulo:
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
--------------------------------------------------------------------------------
Eliminar el sonido "Beep" cuando pulsamos Enter en un TextBox:
Crear un nuevo proyecto e insertar un TextBox:
Peguar el siguiente código en el formulario:
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Or KeyAscii = 9 Then KeyAscii = 0
End Sub
--------------------------------------------------------------------------------
Ocultar y mostrar el puntero del ratón:
Crear un nuevo proyecto e insertar dos ButtonClick y un Módulo:
Pegue el siguiente código en el formulario:
Private Sub Command1_Click()
result = ShowCursor(False)
End Sub
Private Sub Command2_Click()
result = ShowCursor(True)
End Sub
Usar las teclas alternativas Alt+O para ocultarlo y Alt+M para mostrarlo.
Peguar el siguiente código en el módulo:
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
--------------------------------------------------------------------------------
Calcular el número de serie de un disco:
Crear un nuevo proyecto e insertar el siguiente código en el formulario:
Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA"
(ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize
As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags
As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)
Private Sub Form_Load()
Dim cad1 As String * 256
Dim cad2 As String * 256
Dim numSerie As Long
Dim longitud As Long
Dim flag As Long
unidad = "C:\"
Call GetVolumeInformation(unidad, cad1, 256, numSerie, longitud, flag, cad2, 256)
MsgBox "Numero de Serie de la unidad " & unidad & " = " & numSerie
End Sub
--------------------------------------------------------------------------------
Ejemplo de un mailer en base64.
Private Sub Base64_Click() Dim Caracter As String * 1 Dim Trio(3) As Integer Dim Cont As Integer Dim ContLinea As Integer Dim Cuatro(4) As Integer Dim Base64 As String
Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
ContLinea = 0
MensajeSaliente = ""
MensajeEntrante = ""
If Cfg.FicheroAnexo <> "" Then
Open NFich For Binary As #3 Len = 3
Cont = 0
ContTotal = 0
Progreso.Max = FileLen(NFich)
While Not ContTotal = LOF(3)
ContTotal = ContTotal + 1
Caracter = Input(1, 3)
Cont = Cont + 1
Trio(Cont) = Asc(Caracter)
'MensajeSaliente = MensajeSaliente + Caracter
If Cont = 3 Then
Cuatro(1) = Int(Trio(1) / 4)
Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2) / 16)
Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4 + Int(Trio(3) / 64)
Cuatro(4) = Trio(3) - Int(Trio(3) / 64) * 64
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1)
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(4) + 1, 1)
Cont = 0
ContLinea = ContLinea + 4
If ContLinea = 76 Then
MensajeEntrante = MensajeEntrante + vbCrLf
ContLinea = 0
End If
End If
DoEvents
Wend
Select Case Cont
Case 1
Cuatro(1) = Int(Trio(1) / 4)
Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1) + "=="
Case 2
Cuatro(1) = Int(Trio(1) / 4)
Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2) / 16)
Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)
MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1) + "="
End Select
Close #3
End If
End Sub
ver proyecto 1 http://taringa.net/posts/info/2273239/Crear-en--Visual-Basic-Manual.html
ver proyecto 2 http://taringa.net/posts/info/2273271/Crear-en-Visual-Basic-Manual-Part-2.html