Codigos De Programas

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: Private Declare Function 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: 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 = "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, 1440, 1440, 1440 End Sub 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

Nuevo Para abrir: Código: Dim foo As Integer foo = FreeFile Open "C:\Archivo.txt" For Input As #foo Text1.Text = Input(LOF(foo), #foo) Close #foo Para guardar: Código: Dim foo As Integer foo = FreeFile Open "C:\Archivo.txt" For Output As #foo Print #foo, Text1.Text Close #foo dialogos: Ese es para Abrir Código: Dim strOpen As String

CommonDialog1.ShowOpen strOpen = CommonDialog1.FileName Text1.LoadFile strOpen Text1.LoadFile strClose Ese para guardar Código: Dim strNewFile As String CommonDialog1.ShowSave strNewFile = CommonDialog1.FileName Text1.SaveFile strNewFile

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 *) Esta función ha sido corregida por un error en las etiquetas, 96 corresponde a pequeñas y 120 a Grandes, agradecimientos a Andrés Moral Gutiérrez por su correción (01/06/1998)

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 Private Private Private Private

Const Const Const Const Const

DRIVE_REMOVABLE = 2 DRIVE_FIXED = 3 DRIVE_REMOTE = 4 DRIVE_CDROM = 5 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 Public Public Public Public

Const Const Const Const Const

PROCESSOR_INTEL_386 = 386 PROCESSOR_INTEL_486 = 486 PROCESSOR_INTEL_PENTIUM = 586 PROCESSOR_MIPS_R4000 = 4000 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 Para Windows 2000/NT V_ID_CONEXION = Shell ("rasphone.exe -d " & V_NOMBRE_DE_LA_CONEXION_DIALUP, 1)

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 Nuevo: Private Sub Text1_Keypress(KeyAscii As Integer) If Not IsNumeric(Chr$(KeyAscii)) And KeyAscii <> 8 Then KeyAscii = 0 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 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 Dim Dim Dim

Sub Command1_Click() Car As String * 128 Longitud, Es As Integer 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