Como crear un
grupo de programas:
Muy útil para crear instalaciones
por ejemplo:
Añadir un textbox y hacerlo oculto.
Una vez oculto,
escribir estas líneas sustituyendo "Nombre del Grupo" por que que se desea
crear,
y que lo colocamos en Inicio -> Programas.
Private Sub Command1_Click()
Text1.LinkTopic = "Progman|Progman"
Text1.LinkMode = 2
Text1.LinkExecute "[CreateGroup
(" + "Nombre del Grupo" + ")]"
End Sub
Vaciar la carpeta
de Documentos de Windows:
Inicie un nuevo proyecto y
añada el siguiente código:
SHAddToRecentDocs Lib "Shell32"
(ByVal lFlags As Long, ByVal lPv As Long)
As Long
Private Sub Form_Load()
SHAddToRecentDocs 0, 0
End Sub
Abrir la ventana
de Propiedades de agregar o quitar
aplicaciones:
Añada el siguiente código:
Private Sub
Command1_Click()
X = Shell("Rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl
@0")
End Sub
Uso de
Random:
La función Rnd o Random posee la virtud de obtener números
aleatorios entre 0 y 1:
El único inconveniente a la hora de usar
Rnd, es que hay que inicializarlo, en otro caso,
el resultado de la
función Rnd, será siempre el mismo dentro de un determinado
ordenador.
Por ejemplo, el código:
Private Sub Form_Load()
Dim Num As Double
Num = Rnd
MsgBox Num
End Sub
Nos daría como resultado
siempre el mismo número.
Para solucionar este problema, debemos
escribir la sentencia Randomize antes de llamar
a la función
Rnd. De esta manera, la función Rnd actuará
correctamente.
El código quedaría así:
Private Sub Form_Load()
Dim Num As Double
Randomize
Num = Rnd
MsgBox Num
End Sub
Calcular la
etiqueta o label de un disco duro:
Hallar la etiqueta o label del
mismo disco
duro:
Escribir el siguiente código:
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 = "D:\"
Call GetVolumeInformation(unidad,
cad1, 256, numSerie, longitud,
flag, cad2, 256)
MsgBox "Label de la unidad " &
unidad & " = " & cad1
End Sub
Imprimir un
RichTextBox tal y como se ve:
Imprimir un RichTextBox con su
formato original.
Private Sub Command1_Click()
On Error GoTo
ErrorDeImpresion
Printer.Print ""
RichTextBox1.SelPrint
Printer.hDC
Printer.EndDoc
Exit Sub
ErrorDeImpresion:
Exit
Sub
End Sub
Otra forma:
En el Formulario [Form1 por defecto] :
Private Sub Form_Load()
Dim LineWidth As Long
Me.Caption = "Rich Text Box
Ejemplo de Impresion"
Command1.Move 10, 10, 600, 380
Command1.Caption = "&Imprimir"
RichTextBox1.SelFontName =
"Verdana, Tahoma, Arial"
RichTextBox1.SelFontSize = 10
LineWidth = WYSIWYG_RTF(RichTextBox1,
1440, 1440)
Me.Width = LineWidth + 200
End Sub
Private Sub Form_Resize()
RichTextBox1.Move 100, 500,
Me.ScaleWidth - 200, Me.ScaleHeight
- 600
End Sub
Private Sub Command1_Click()
PrintRTF RichTextBox1, 1440,
Crear un módulo y
escribir:
Private Type Rect
Left As Long
Top As Long
Right
As Long
Bottom As Long
End Type
Private Type
CharRange
cpMin As Long
cpMax As Long
End Type
Private
Type FormatRange
hdc As Long
hdcTarget As Long
rc As
Rect
rcPage As Rect
chrg As CharRange
End Type
Private
Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long
= WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER +
72
Private Const PHYSICALOFFSETX As Long = 112
Private Const
PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps
Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As
Long
Private Declare Function SendMessage Lib "USER32" Alias
"SendMessageA" _
(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As
Long, lp As Any) As Long
Private Declare Function CreateDC Lib "gdi32"
Alias "CreateDCA" _
(ByVal lpDriverName As String, ByVal lpDeviceName
As String, _
ByVal lpOutput As Long, ByVal lpInitData As Long) As
Long
Public Function WYSIWYG_RTF(RTF As RichTextBox,
LeftMarginWidth As Long, _
RightMarginWidth As Long) As Long
Dim
LeftOffset As Long, LeftMargin As Long, RightMargin As Long
Dim
LineWidth As Long
Dim PrinterhDC As Long
Dim r As
Long
Printer.Print Space(1)
Printer.ScaleMode =
vbTwips
LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc,
_
PHYSICALOFFSETX), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth
- LeftOffset
RightMargin = (Printer.Width - RightMarginWidth) -
LeftOffset
LineWidth = RightMargin - LeftMargin
PrinterhDC =
CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)
r =
SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _
ByVal
LineWidth)
Printer.KillDoc
WYSIWYG_RTF = LineWidth
End
Function
Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As
Long, _
TopMarginHeight, RightMarginWidth, BottomMarginHeight)
Dim
LeftOffset As Long, TopOffset As Long
Dim LeftMargin As Long, TopMargin
As Long
Dim RightMargin As Long, BottomMargin As Long
Dim fr As
FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim
TextLength As Long
Dim NextCharPosition As Long
Dim r As
Long
Printer.Print Space(1)
Printer.ScaleMode =
vbTwips
LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc,
_
PHYSICALOFFSETX), vbPixels, vbTwips)
TopOffset =
Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels,
vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin =
TopMarginHeight - TopOffset
RightMargin = (Printer.Width -
RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height -
BottomMarginHeight) - TopOffset
rcPage.Left = 0
rcPage.Top =
0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom =
Printer.ScaleHeight
rcDrawTo.Left = LeftMargin
rcDrawTo.Top =
TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom =
BottomMargin
fr.hdc = Printer.hdc
fr.hdcTarget =
Printer.hdc
fr.rc = rcDrawTo
fr.rcPage = rcPage
fr.chrg.cpMin =
0
fr.chrg.cpMax = -1
TextLength =
Len(RTF.Text)
Do
NextCharPosition = SendMessage(RTF.hWnd,
EM_FORMATRANGE, True, fr)
If NextCharPosition >= TextLength Then
Exit Do
fr.chrg.cpMin =
NextCharPosition
Printer.NewPage
Printer.Print Space(1)
fr.hDC =
Printer.hDC
fr.hDCTarget = Printer.hDC
Loop
Printer.EndDoc
r =
SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
End
Sub
Como obtener el
directorio desde donde estamos ejecutando nuestro
programa:
Escribir el siguiente código:
Private Sub
Form_Load()
Dim Directorio as String
ChDir App.Path
ChDrive
App.Path
Directorio = App.Path
If Len(Directorio) > 3
Then
Directorio = Directorio & "\"
End If
End
Sub
Determinar si un
fichero existe o no:
Escriba el siguiente código: (una
de tanta maneras aparte de Dir$())
Private Sub Form_Load()
On
Error GoTo Fallo
x = GetAttr("C:\Autoexec.bat")
MsgBox "El fichero
existe."
Exit Sub
Fallo:
MsgBox "El fichero no existe."
End
Sub
Capturar la
pantalla entera o la ventana activa:
Añadir dos botones y escribir el
siguiente código:
Private Declare Sub
keybd_event Lib "user32" (ByVal bVk As Byte,
ByVal bScan As Byte, ByVal
dwFlags As Long,
ByVal dwExtraInfo As Long)
Private Sub
Command1_Click()
'Captura la ventana activa
keybd_event 44, 0,
0&, 0&
End Sub
Private Sub Command2_Click()
'Captura
toda la pantalla
keybd_event 44, 1, 0&, 0&
End
Sub
Salvar el
contenido de un TextBox a un fichero en
disco:
Añada el siguiente código:
Private Sub
Command1_Click()
Dim canalLibre As Integer
'Obtenemos un canal libre
que nos dará
'el sistema oparativo para poder operar
canalLibre =
FreeFile
'Abrimos el fichero en el canal dado
Open "C:\fichero.txt"
For Output As #canalLibre
'Escribimos el contenido del TextBox al
fichero
Print #canalLibre, Text1
Close #canalLibre
End
Sub
Como desplegar la
lista de un ComboBox automáticamente:
Insertar un ComboBox y un Botón
en un nuevo proyecto y escribir el siguiente código:
Private
Declare Function SendMessageLong Lib "user32" Alias
"SendMessageA"
(ByVal hwnd As Long, ByVal wMsg As Long,
ByVal wParam As Long, ByVal
lParam As Long) As Long
Private Sub
Form_Load()
Combo1.Clear
Combo1.AddItem "Objeto 1"
Combo1.AddItem
"Objeto 2"
Combo1.AddItem "Objeto 3"
Combo1.AddItem "Objeto
4"
Combo1.AddItem "Objeto 5"
Combo1.AddItem "Objeto
6"
Combo1.AddItem "Objeto 7"
Combo1.Text = "Objeto 1"
End
Sub
Private Sub Command1_Click()
'ComboBox desplegado
Dim
Resp As Long
Resp = SendMessageLong(Combo1.hwnd, &H14F, True,
0)
End Sub
Nota: Resp =
SendMessageLong(Combo1.hwnd, &H14F, False, 0) oculta la lista
desplegada de un ComboBox, aunque esto sucede también cuando cambiamos
el focus a otro control o al formulario.
Selección y
eliminación de todos los elementos de un
ListBox:
Insertar un ListBox y dos Botón en un nuevo proyecto. Poner la
propiedad MultiSelect del ListBox a "1 - Simple" y escriba el siguiente
código:
Private Declare Function SendMessageLong Lib "user32"
Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,
ByVal
wParam As Long, ByVal lParam As Long) As Long
Private Sub
Form_Load()
List1.AddItem "Texto 1"
List1.AddItem "Texto
2"
List1.AddItem "Texto 3"
List1.AddItem "Texto 4"
List1.AddItem
"Texto 5"
List1.AddItem "Texto 6"
List1.AddItem "Texto 7"
End
Sub
Private Sub Command1_Click()
'Seleccion de todo el
contenido
Dim Resp As Long
Resp = SendMessageLong(List1.hwnd,
&H185&, True, -1)
End Sub
Private Sub
Command2_Click()
'Eliminacion de todos los elementos
seleccionados
Dim Resp As Long
Resp = SendMessageLong(List1.hwnd,
&H185&, False, -1)
End Sub
Calcular el
tamaño de fuentes de letra:
Es útil para utilizar con la
propiedad Resize sobre los controles al cambiar de resolución de
pantalla.
Escribir el siguiente código:
Private Declare Function
GetDeviceCaps Lib "gdi32" (ByVal
hdc As Long, ByVal nIndex As Long) As
Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd
As
Long) As Long
Private Declare Function GetDesktopWindow Lib "user32"
()
As Long
Private Sub Form_Load()
Dim ObCaps As Long
Dim
ObDC As Long
Dim ObDesktop As Long
Dim Cad As String
ObDesktop =
GetDesktopWindow()
ObDC = GetDC(ObDesktop)
ObCaps =
GetDeviceCaps(ObDC, 88)
If ObCaps = 96 Then Cad = "Pequeñas
If
ObCaps = 120 Then Cad = "Grandes"
MsgBox "Fuentes de letra " &
Cad
End Sub
Provocar la
trasparencia de un formulario:
Escribir el siguiente
código:
Private Declare Function SetWindowLong Lib "user32"
Alias
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As
Long,
ByVal dwNewLong As Long) As Long
Private Sub
Form_Load()
Dim Resp As Long
Resp = SetWindowLong(Me.hwnd, -20,
&H20&)
Form1.Refresh
End Sub
Pasar de un
TextBox a otro al pulsar Enter:
Insertar tres TextBox y escribir
el siguiente código:
Private Sub Text1_KeyPress(KeyAscii As
Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii =
0
End If
End Sub
Private Sub Text2_KeyPress(KeyAscii As
Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii =
0
End If
End Sub
Private Sub Text3_KeyPress(KeyAscii As
Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii =
0
End If
End Sub
otra forma:
Insertar tres TextBox,
cambiar la propiedad KeyPreview del formulario a True y escribir el
siguiente código:
Private Sub Form_KeyPress(KeyAscii As
Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii =
0
End If
End Sub
Usar IF THEN ELSE
ENDIF en una misma línea:
Insertar un CommandButton y
un TextBox y escribir el siguiente código:
Private Sub
Command1_Click()
Dim I As Integer
Dim A As String
I = 3
A =
IIf(I <> 1, "True", "False")
Text1.Text = A
End
Sub
Convertir un
texto a mayúsculas o minúsculas:
Crear un formulario y situar un
TextBox. Escribir:
Private Sub Text1_Change()
Dim I As
Integer
Text1.Text = UCase(Text1.Text)
I =
Len(Text1.Text)
Text1.SelStart = I
End Sub
Presentar la
ventana AboutBox (Acerca de) por defecto:
Escribir el siguiente código en
el formulario:
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,
"Título Programa", "Copyright 1997, Dueño de la aplicación",
Me.Icon)
End Sub
Incrementar un
menú en ejecución:
Abrir un proyecto nuevo, y haga
doble click sobre el formulario. Meidante el gestór de menús
escribir
lo siguiente:
Caption ->
Editor
Name -> MnuEditor
Pulse Insertar y el
botón "->"
Caption -> Añadir
Name ->
MnuAñadir
Pulse Insertar
Caption ->
Quitar
Name -> MnuQuitar
Enabled
-> False
Pulse Insertar
Caption ->
Salir
Name -> MnuSalir
Pulse
Insertar
Caption -> -
Name ->
MnuIndex
Index -> 0
Pulse
Aceptar
Escribir el siguiente código en el
formulario:
Private ultElem As Integer
Private Sub
Form_Load()
ultElem = 0
End Sub
Private Sub
MnuQuitar_Click()
Unload MnuIndex(ultElem)
ultElem = ultElem -
1
If ultElem = 0 Then
MnuQuitar.Enabled = False
End If
End
Sub
Private Sub MnuSalir_Click()
End
End Sub
Private
Sub MnuAñadir_Click()
ultElem = ultElem + 1
Load
MnuIndex(ultElem)
MnuIndex(ultElem).Caption = "Menu -> " +
Str(ultElem)
MnuQuitar.Enabled = True
End Sub
Cambiar el fondo
de Windows desde
Visual Basic:
Crear un formulario y
escribir:
Private 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
Private Sub Form_Load()
Dim fallo As Integer
fallo =
SystemParametersInfo(20, 0, "C:\WINDOWS\FONDO.BMP", 0)
End
Sub
Calcular el
número de colores de video
del modo actual de
Windows:
Crear un formulario y un TextBox y escribir:
Private
Declare Function GetDeviceCaps Lib "gdi32"
(ByVal hdc As Long, ByVal
nIndex As Long) As Long
Private Sub Form_Load()
i = (2 ^
GetDeviceCaps(Form1.hdc, 12)) ^
GetDeviceCaps(Form1.hdc,
14)
Text1.Text = CStr(i) & " colores."
End Sub
Ajustar un Bitmap
a la pantalla:
Crear un formulario con un BitMap cualquiera y una etiqueta o
Label con los atributos que quiera.
Escribir lo
siguiente:
Private Sub Form_Paint()
Dim i As Integer
For i =
0 To Form1.ScaleHeight Step Picture1.Height
For j = 0 To
Form1.ScaleWidth Step Picture1.Width
PaintPicture Picture1, j, i,
Picture1.Width,
Picture1.Height
Next
Next
End
Sub
Private Sub Form_Resize()
Picture1.Left = -(Picture1.Width +
200)
Picture1.Top = -(Picture1.Height + 200)
Label1.Top =
100
Label1.Left = 100
End Sub
Detectar la
unidad del CD-ROM:
Si para instalar una aplicación o
ejecutar un determinado software necesitas saber si existe el
CD-ROM:.
Crear un formulario con una
etiqueta y escribir lo siguiente:
Option Explicit
Private
Declare Function GetDriveType Lib "kernel32" Alias
"GetDriveTypeA"
(ByVal nDrive As String) As Long
Private Declare Function
GetLogicalDriveStrings Lib "kernel32" Alias
"GetLogicalDriveStringsA"
(ByVal nBufferLength As Long, ByVal
lpBuffer As String) As
Long
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED =
3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM =
5
Private Const DRIVE_RAMDISK = 6
Function
StripNulls(startStrg$) As String
Dim c%, item$
c% = 1
Do
If
Mid$(startStrg$, c%, 1) = Chr$(0) Then
item$ = Mid$(startStrg$, 1, c% -
1)
startStrg$ = Mid$(startStrg$, c% + 1,
Len(startStrg$))
StripNulls$ = item$
Exit Function
End If
c% =
c% + 1
Loop
End Function
Private Sub Form_Load()
Dim
r&, allDrives$, JustOneDrive$, pos%, DriveType&
Dim CDfound As
Integer
allDrives$ = Space$(64)
r& =
GetLogicalDriveStrings(Len(allDrives$), allDrives$)
allDrives$ =
Left$(allDrives$, r&)
Do
pos% = InStr(allDrives$, Chr$(0))
If
pos% Then
JustOneDrive$ = Left$(allDrives$, pos%)
allDrives$ =
Mid$(allDrives$, pos% + 1, Len(allDrives$))
DriveType& =
GetDriveType(JustOneDrive$)
If DriveType& = DRIVE_CDROM
Then
CDfound% = True
Exit Do
End If
End If
Loop Until
allDrives$ = "" Or DriveType& = DRIVE_CDROM
If CDfound%
Then
label1.Caption = "La unidad de CD-ROM corresponde a la
unidad:
" & UCase$(JustOneDrive$)
Else
label1.Caption = "Su sistema no
posee CD-ROM o unidad
no encontrada."
End If
End
Sub
Calcular la
profundidad de color (bits por pixel) y resolución de
Windows:
Crear un formulario y un TextBox y escribir:
Private
Declare Function GetDeviceCaps Lib "gdi32"
(ByVal hdc As Long, ByVal
nIndex As Long) As Long
Private Sub Form_Load()
Dim col, bit,
largo, alto As Integer
col = GetDeviceCaps(Form1.hdc, 12)
If col = 1
Then
bit = GetDeviceCaps(Form1.hdc, 14)
If bit = 1
Then
Text1.Text = "Resolucion de 1 bit / 2 colores"
ElseIf bit = 4
Then
Text1.Text = "Resolucion de 4 bits / 16 colores"
End
If
ElseIf col = 8 Then
Text1.Text = "Resolucion de 8 bits / 256
colores"
ElseIf col = 16 Then
Text1.Text = "Resolucion de 16 bits /
65000 colores"
Else
Text1.Text = "Resolucion de 16 M colores"
End
If
largo = GetDeviceCaps(Form1.hdc, 8)
alto =
GetDeviceCaps(Form1.hdc, 10)
Text1.Text = Text1.Text & " " &
largo & "x" & alto & " pixels"
End Sub
Comprobar si el
sistema posee tarjeta de sonido:
Crear un formulario y
escribir:
Private Declare Function waveOutGetNumDevs
Lib "winmm.dll" () As Long
Private Sub Form_Load()
Dim inf As
Integer
inf = waveOutGetNumDevs()
If inf > 0 Then
MsgBox
"Tarjeta de sonido soportada.", vbInformation,
"Informacion: Tarjeta de
sonido"
Else
MsgBox "Tarjeta de sonido no soportada.",
vbInformation,
"Informacion: Tarjeta de sonido"
End If
End
End
Sub
Crear una ventana
con la Información del Sistema:
Crear un formulario e insertar un
módulo y escribir en el formulario lo siguiente:
Private Sub
Form_Load()
Dim msg As String
MousePointer = 11
Dim verinfo As
OSVERSIONINFO
verinfo.dwOSVersionInfoSize = Len(verinfo)
ret% =
GetVersionEx(verinfo)
If ret% = 0 Then
MsgBox "Error Obteniendo
Information de la Version"
End
End If
Select Case
verinfo.dwPlatformId
Case 0
msg = msg + "Windows 32s "
Case
1
msg = msg + "Windows 95 "
Case 2
msg = msg + "Windows NT
"
End Select
ver_major$ = verinfo.dwMajorVersion
ver_minor$ =
verinfo.dwMinorVersion
build$ = verinfo.dwBuildNumber
msg = msg +
ver_major$ + "." + ver_minor$
msg = msg + " (Construido " + build$ +
")" + vbCrLf + vbCrLf
Dim sysinfo As SYSTEM_INFO
GetSystemInfo
sysinfo
msg = msg + "CPU: "
Select Case
sysinfo.dwProcessorType
Case PROCESSOR_INTEL_386
msg = msg +
"Procesador Intel 386 o compatible." + vbCrLf
Case
PROCESSOR_INTEL_486
msg = msg + "Procesador Intel 486 o compatible." +
vbCrLf
Case PROCESSOR_INTEL_PENTIUM
msg = msg + "Procesador Intel
Pentium o compatible." + vbCrLf
Case PROCESSOR_MIPS_R4000
msg = msg
+ "Procesador MIPS R4000." + vbCrLf
Case PROCESSOR_ALPHA_21064
msg =
msg + "Procesador DEC Alpha 21064." + vbCrLf
Case Else
msg = msg +
"Procesador (desconocido)." + vbCrLf
End Select
msg = msg +
vbCrLf
Dim memsts As MEMORYSTATUS
Dim
memory&
GlobalMemoryStatus memsts
memory& =
memsts.dwTotalPhys
msg = msg + "Memoria Fisica Total: "
msg = msg +
Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLf
memory&
= memsts.dwAvailPhys
msg = msg + "Memoria Fisica Disponible: "
msg =
msg + Format$(memory& \ 1024, "###,###,###") + "Kb" +
vbCrLf
memory& = memsts.dwTotalVirtual
msg = msg + "Memoria
Virtual Total: "
msg = msg + Format$(memory& \ 1024, "###,###,###")
+ "Kb" + vbCrLf
memory& = memsts.dwAvailVirtual
msg = msg +
"Memoria Virtual Disponible: "
msg = msg + Format$(memory& \ 1024,
"###,###,###") + "Kb" + vbCrLf + vbCrLf
MsgBox msg, 0, "Acerca del
Sistema"
MousePointer = 0
End
End Sub
Escribir lo siguiente en el
módulo:
Type SYSTEM_INFO
dwOemID As Long
dwPageSize As
Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress
As Long
dwActiveProcessorMask As Long
dwNumberOrfProcessors As
Long
dwProcessorType As Long
dwAllocationGranularity As
Long
dwReserved As Long
End Type
Type
OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As
Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As
Long
szCSDVersion As String * 128
End Type
Type
MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As
Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile
As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End
Type
Declare Function GetVersionEx
Lib "kernel32"
Alias
"GetVersionExA" (LpVersionInformation
As OSVERSIONINFO) As
Long
Declare Sub GlobalMemoryStatus Lib "kernel32"
(lpBuffer As
MEMORYSTATUS)
Declare Sub GetSystemInfo Lib "kernel32"
(lpSystemInfo
As SYSTEM_INFO)
Public Const PROCESSOR_INTEL_386 = 386
Public
Const PROCESSOR_INTEL_486 = 486
Public Const PROCESSOR_INTEL_PENTIUM =
586
Public Const PROCESSOR_MIPS_R4000 = 4000
Public Const
PROCESSOR_ALPHA_21064 = 21064
Mostrar un
fichero AVI a pantalla completa:
Crear un formulario y
escribir:
Private Declare Function mciSendString Lib
"winmm.dll"
Alias "mciSendStringA"
(ByVal lpstrCommand As String,
ByVal
lpstrReturnString As Any,
ByVal uReturnLength As Long,
ByVal
hwndCallback As Long) As Long
Private Sub Form_Load()
CmdStr$ =
"play e:\media\avi\nombre.avi fullscreen"
ReturnVal& =
mciSendString(CmdStr$, 0&, 0, 0&)
End Sub
Crear un link con
un programa añadiéndolo al grupo de programas situado
en
Inicio ->
Programas o Start -> Programs:
Crear un formulario y
escribir:
Private Declare Function fCreateShellLink
Lib
"STKIT432.DLL" (ByVal lpstrFolderName
As String, ByVal lpstrLinkName As
String,
ByVal lpstrLinkPath As String,
ByVal lpstrLinkArgs As
String) As Long
Private Sub Form_Load()
iLong =
fCreateShellLink("",
"Visual Basic", "C:\Archivos de
Programa\DevStudio\Vb\vb5.exe", "")
End Sub
Apagar el equipo,
reiniciar Windows, reiniciar el Sistema:
Añadir tres botones a un
formulario y escribir lo siguiente en el código del
formulario:
Private Declare Function ExitWindowsEx& Lib
"user32" (ByVal
uFlags&, ByVal dwReserved&)
Private Sub
Command1_Click()
Dim i as integer
i = ExitWindowsEx(1, 0&)
'Apaga el equipo
End Sub
Private Sub Command2_Click()
Dim i
as integer
i = ExitWindowsEx(0, 0&) 'Reinicia Windows con nuevo
usuario
End Sub
Private Sub Command3_Click()
Dim i as
integer
i = ExitWindowsEx(2, 0&) 'Reinicia el Sistema
End
Sub
Borrar un fichero
y enviarlo a la papelera de reciclaje:
Crear un formulario y escribir el
siguiente código:
Private Type
SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo
As String
fFlags As Integer
fAnyOperationsAborted As
Boolean
hNameMappings As Long
lpszProgressTitle As String
End
Type
Private Declare Function SHFileOperation Lib "shell32.dll"
Alias
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As
Long
Private Const FO_DELETE = &H3
Private Const
FOF_ALLOWUNDO = &H40
Public Sub PapeleraDeReciclaje(ByVal
Fichero As String)
Dim SHFileOp As SHFILEOPSTRUCT
Dim RetVal As
Long
With SHFileOp
.wFunc = FO_DELETE
.pFrom =
FileName
.fFlags = FOF_ALLOWUNDO
End With
RetVal =
SHFileOperation(SHFileOp)
End Sub
Private Sub
Form_Load()
Recycle "c:\a.txt"
End Sub
El programa preguntará si
deseamos o no eliminar el fichero y enviarlo a la papelera de
reciclaje.
El parámetro .fFlags
nos permitirá recuperar el fichero de la papelera si lo
deseamos
Si eliminamos esta línea, el
fichero no podrá ser recuperado.
Abrir el Acceso
telefónico a Redes de Windows y ejecutar una
conexión:
Crear un formulario y escribir el siguiente código:
Private Sub
Form_Load()
Dim AbrirConexion As Long
AbrirConexion =
Shell("rundll32.exe rnaui.dll,RnaDial " &
"ConexiónInternet",
1)
SendKeys "{ENTER}"
End Sub
Situar una
ScroolBar horizontal en un ListBox:
Crear un formulario y escribir el
siguiente código:
Private Declare Function
SendMessage Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long,
ByVal wMsg As Long,
ByVal wParam As Long, lParam As Any) As
Long
Private Sub Form_Load()
Dim x As Integer, i As
Integer
For i = 1 To 20
List1.AddItem "El número final de la
selección es el " & i
Next i
x = SendMessage(List1.hwnd,
&H194, 200, ByVal 0&)
End Sub
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
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
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
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,
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
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)
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
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