Hola que tal a todos este es mi primer blog y quisiera aportar algo a aquellas personas que les guste usar el visual basic 6. A muchas personas ya sean novatos (como yo) o profesionales les gusta este programa, despierta el interes de programar, para mi en lo personal tiene un entorno bastante amigable, manipulas ventanas creas botones, cajas de texto, etiquetas de texto, todo lo necesario para hacer sistemas para uso personal. he creado sistemas como el de un videocentro, navegadores, alarmas, mandar msjs y apagar una computadora remotamente. Practicamente se puede hacer todo lo que tu quieras con este programa, aunque el 6.0 esta un poco obsoleto, pero no deja de ser util.
Para aquellos que tengan el sistema operativo Linux/Ubuntu les aconsejo que usen Gambas, este programa es como el visual basic de windows, tiene algunas diferencias pero no deja de ser potente, ademas de que es compatible con cualquier distribucion de Linux, en el caso de ubuntu desplegamos el menu principal y buscamos la opcion agregar/quitar programas, posteriormente buscamos en la pestaña programacion y buscamos gambas, despues presionamos aplicar cambios, y nos aparecerá una ventana que no dice las aplicaciones a instalar, presionamos aceptar o instalar(no recuerdo como dice) y esperamos a que se instale.
Tambien se puede hacer abriendo la consola, que viene siendo como algo parecido a la consola de ms-dos de windows y escribimos los siguiente: // sudo apt-get install gambas (sin diagonales) y listo solo esperamos a que se instale.
Bueno les dejo estos codigos para que los chequen:
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 = "ProgmanProgman"
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
Private Sub Command1_Click()
Text1.LinkTopic = "ProgmanProgman"
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 ErrorDeImpresionPrinter.Print ""RichTextBox1.SelPrint Printer.hDCPrinter.EndDocExit SubErrorDeImpresion:Exit SubEnd 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
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 ErrorDeImpresionPrinter.Print ""RichTextBox1.SelPrint Printer.hDCPrinter.EndDocExit SubErrorDeImpresion:Exit SubEnd 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 RectLeft As LongTop As LongRight As LongBottom As LongEnd TypePrivate Type CharRangecpMin As LongcpMax As LongEnd TypePrivate Type FormatRangehdc As LonghdcTarget As Longrc As RectrcPage As Rectchrg As CharRangeEnd TypePrivate Const WM_USER As Long = &H400Private Const EM_FORMATRANGE As Long = WM_USER + 57Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72Private Const PHYSICALOFFSETX As Long = 112Private Const PHYSICALOFFSETY As Long = 113Private Declare Function GetDeviceCaps Lib "gdi32" ( _ByVal hdc As Long, ByVal nIndex As Long) As LongPrivate Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As LongPrivate Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _(ByVal lpDriverName As String, ByVal lpDeviceName As String, _ByVal lpOutput As Long, ByVal lpInitData As Long) As LongPublic Function WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, _RightMarginWidth As Long) As LongDim LeftOffset As Long, LeftMargin As Long, RightMargin As LongDim LineWidth As LongDim PrinterhDC As LongDim r As LongPrinter.Print Space(1)Printer.ScaleMode = vbTwipsLeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _PHYSICALOFFSETX), vbPixels, vbTwips)LeftMargin = LeftMarginWidth - LeftOffsetRightMargin = (Printer.Width - RightMarginWidth) - LeftOffsetLineWidth = RightMargin - LeftMarginPrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)r = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _ByVal LineWidth)Printer.KillDocWYSIWYG_RTF = LineWidthEnd FunctionPublic Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _TopMarginHeight, RightMarginWidth, BottomMarginHeight)Dim LeftOffset As Long, TopOffset As LongDim LeftMargin As Long, TopMargin As LongDim RightMargin As Long, BottomMargin As LongDim fr As FormatRangeDim rcDrawTo As RectDim rcPage As RectDim TextLength As LongDim NextCharPosition As LongDim r As LongPrinter.Print Space(1)Printer.ScaleMode = vbTwipsLeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _PHYSICALOFFSETX), vbPixels, vbTwips)TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _PHYSICALOFFSETY), vbPixels, vbTwips)LeftMargin = LeftMarginWidth - LeftOffsetTopMargin = TopMarginHeight - TopOffsetRightMargin = (Printer.Width - RightMarginWidth) - LeftOffsetBottomMargin = (Printer.Height - BottomMarginHeight) - TopOffsetrcPage.Left = 0rcPage.Top = 0rcPage.Right = Printer.ScaleWidthrcPage.Bottom = Printer.ScaleHeightrcDrawTo.Left = LeftMarginrcDrawTo.Top = TopMarginrcDrawTo.Right = RightMarginrcDrawTo.Bottom = BottomMarginfr.hdc = Printer.hdcfr.hdcTarget = Printer.hdcfr.rc = rcDrawTofr.rcPage = rcPagefr.chrg.cpMin = 0fr.chrg.cpMax = -1TextLength = Len(RTF.Text)DoNextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr)If NextCharPosition >= TextLength Then Exit Dofr.chrg.cpMin = NextCharPositionPrinter.NewPagePrinter.Print Space(1)fr.hDC = Printer.hDCfr.hDCTarget = Printer.hDCLoopPrinter.EndDocr = 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.PathChDrive App.PathDirectorio = App.Path
If Len(Directorio) > 3 ThenDirectorio = 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 Fallox = GetAttr("C:\Autoexec.bat")MsgBox "El fichero existe."Exit SubFallo: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 activakeybd_event 44, 0, 0&, 0&End SubPrivate Sub Command2_Click()'Captura toda la pantallakeybd_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 operarcanalLibre = FreeFile'Abrimos el fichero en el canal dadoOpen "C:\fichero.txt" For Output As #canalLibre'Escribimos el contenido del TextBox al ficheroPrint #canalLibre, Text1Close #canalLibreEnd Sub
Nuevo
Para abrir:
Código:Dim foo As Integerfoo = FreeFileOpen "C:\Archivo.txt" For Input As #fooText1.Text = Input(LOF(foo), #foo)Close #foo
Para guardar:
Código:Dim foo As Integerfoo = FreeFileOpen "C:\Archivo.txt" For Output As #fooPrint #foo, Text1.TextClose #foo
dialogos:
Ese es para Abrir
Código:Dim strOpen As StringCommonDialog1.ShowOpenstrOpen = CommonDialog1.FileNameText1.LoadFile strOpenText1.LoadFile strClose
Ese para guardar
Código:Dim strNewFile As StringCommonDialog1.ShowSavestrNewFile = CommonDialog1.FileNameText1.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 LongPrivate Sub Form_Load()Combo1.ClearCombo1.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 SubPrivate Sub Command1_Click()'ComboBox desplegadoDim Resp As LongResp = SendMessageLong(Combo1.hwnd, &H14F, True, 0)End Sub
Nota: Resp = SendMessageLong(Combo1.hwnd, &H14F, False, 0) oculta la lista desplegadade 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 ListBoxa "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 LongPrivate 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 SubPrivate Sub Command1_Click()'Seleccion de todo el contenidoDim Resp As LongResp = SendMessageLong(List1.hwnd, &H185&, True, -1)End SubPrivate Sub Command2_Click()'Eliminacion de todos los elementos seleccionadosDim Resp As LongResp = 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" (ByValhdc As Long, ByVal nIndex As Long) As LongPrivate Declare Function GetDC Lib "user32" (ByVal hwndAs Long) As LongPrivate Declare Function GetDesktopWindow Lib "user32" ()As LongPrivate Sub Form_Load()Dim ObCaps As LongDim ObDC As LongDim ObDesktop As LongDim Cad As StringObDesktop = GetDesktopWindow()ObDC = GetDC(ObDesktop)ObCaps = GetDeviceCaps(ObDC, 88)If ObCaps = 96 Then Cad = "PequeñasIf ObCaps = 120 Then Cad = "Grandes"MsgBox "Fuentes de letra " & CadEnd Sub
*) Esta función ha sido corregida por un error en las etiquetas, 96 corresponde a pequeñasy 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 LongPrivate Sub Form_Load()Dim Resp As LongResp = SetWindowLong(Me.hwnd, -20, &H20&)Form1.RefreshEnd 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 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd SubPrivate Sub Text2_KeyPress(KeyAscii As Integer)If KeyAscii = 13 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd SubPrivate Sub Text3_KeyPress(KeyAscii As Integer)If KeyAscii = 13 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd 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 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd 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 IntegerDim A As StringI = 3A = IIf(I <> 1, "True", "False")Text1.Text = AEnd 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 IntegerText1.Text = UCase(Text1.Text)I = Len(Text1.Text)Text1.SelStart = IEnd 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 LongPrivate 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úsescribir lo siguiente:
Caption -> EditorName -> MnuEditorPulse Insertar y el botón "->"Caption -> AñadirName -> MnuAñadirPulse InsertarCaption -> QuitarName -> MnuQuitarEnabled -> FalsePulse InsertarCaption -> SalirName -> MnuSalirPulse InsertarCaption -> -Name -> MnuIndexIndex -> 0Pulse AceptarEscribir el siguiente código en el formulario:Private ultElem As IntegerPrivate Sub Form_Load()ultElem = 0End SubPrivate Sub MnuQuitar_Click()Unload MnuIndex(ultElem)ultElem = ultElem - 1If ultElem = 0 ThenMnuQuitar.Enabled = FalseEnd IfEnd SubPrivate Sub MnuSalir_Click()EndEnd SubPrivate Sub MnuAñadir_Click()ultElem = ultElem + 1Load MnuIndex(ultElem)MnuIndex(ultElem).Caption = "Menu -> " + Str(ultElem)MnuQuitar.Enabled = TrueEnd 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 AsLong, ByVal lpvParam As Any, ByVal fuWinIni As Long) As LongPrivate Sub Form_Load()Dim fallo As Integerfallo = 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 LongPrivate 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 IntegerFor i = 0 To Form1.ScaleHeight Step Picture1.HeightFor j = 0 To Form1.ScaleWidth Step Picture1.WidthPaintPicture Picture1, j, i, Picture1.Width,Picture1.HeightNextNextEnd SubPrivate Sub Form_Resize()Picture1.Left = -(Picture1.Width + 200)Picture1.Top = -(Picture1.Height + 200)Label1.Top = 100Label1.Left = 100End 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 ExplicitPrivate Declare Function GetDriveType Lib "kernel32" Alias"GetDriveTypeA" (ByVal nDrive As String) As LongPrivate Declare Function GetLogicalDriveStrings Lib "kernel32" Alias"GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVallpBuffer As String) As LongPrivate Const DRIVE_REMOVABLE = 2Private Const DRIVE_FIXED = 3Private Const DRIVE_REMOTE = 4Private Const DRIVE_CDROM = 5Private Const DRIVE_RAMDISK = 6Function StripNulls(startStrg$) As StringDim c%, item$c% = 1DoIf Mid$(startStrg$, c%, 1) = Chr$(0) Thenitem$ = Mid$(startStrg$, 1, c% - 1)startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))StripNulls$ = item$Exit FunctionEnd Ifc% = c% + 1LoopEnd FunctionPrivate Sub Form_Load()Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&Dim CDfound As IntegerallDrives$ = Space$(64)r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)allDrives$ = Left$(allDrives$, r&)Dopos% = InStr(allDrives$, Chr$(0))If pos% ThenJustOneDrive$ = Left$(allDrives$, pos%)allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))DriveType& = GetDriveType(JustOneDrive$)If DriveType& = DRIVE_CDROM ThenCDfound% = TrueExit DoEnd IfEnd IfLoop Until allDrives$ = "" Or DriveType& = DRIVE_CDROMIf CDfound% Thenlabel1.Caption = "La unidad de CD-ROM corresponde a launidad: " & UCase$(JustOneDrive$)Elselabel1.Caption = "Su sistema no posee CD-ROM o unidadno encontrada."End IfEnd 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 LongPrivate Sub Form_Load()Dim col, bit, largo, alto As Integercol = GetDeviceCaps(Form1.hdc, 12)If col = 1 Thenbit = GetDeviceCaps(Form1.hdc, 14)If bit = 1 ThenText1.Text = "Resolucion de 1 bit / 2 colores"ElseIf bit = 4 ThenText1.Text = "Resolucion de 4 bits / 16 colores"End IfElseIf col = 8 ThenText1.Text = "Resolucion de 8 bits / 256 colores"ElseIf col = 16 ThenText1.Text = "Resolucion de 16 bits / 65000 colores"ElseText1.Text = "Resolucion de 16 M colores"End Iflargo = 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 LongPrivate Sub Form_Load()Dim inf As Integerinf = waveOutGetNumDevs()If inf > 0 ThenMsgBox "Tarjeta de sonido soportada.", vbInformation,"Informacion: Tarjeta de sonido"ElseMsgBox "Tarjeta de sonido no soportada.", vbInformation,"Informacion: Tarjeta de sonido"End IfEndEnd 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 StringMousePointer = 11Dim verinfo As OSVERSIONINFOverinfo.dwOSVersionInfoSize = Len(verinfo)ret% = GetVersionEx(verinfo)If ret% = 0 ThenMsgBox "Error Obteniendo Information de la Version"EndEnd IfSelect Case verinfo.dwPlatformIdCase 0msg = msg + "Windows 32s "Case 1msg = msg + "Windows 95 "Case 2msg = msg + "Windows NT "End Selectver_major$ = verinfo.dwMajorVersionver_minor$ = verinfo.dwMinorVersionbuild$ = verinfo.dwBuildNumbermsg = msg + ver_major$ + "." + ver_minor$msg = msg + " (Construido " + build$ + ")" + vbCrLf + vbCrLfDim sysinfo As SYSTEM_INFOGetSystemInfo sysinfomsg = msg + "CPU: "Select Case sysinfo.dwProcessorTypeCase PROCESSOR_INTEL_386msg = msg + "Procesador Intel 386 o compatible." + vbCrLfCase PROCESSOR_INTEL_486msg = msg + "Procesador Intel 486 o compatible." + vbCrLfCase PROCESSOR_INTEL_PENTIUMmsg = msg + "Procesador Intel Pentium o compatible." + vbCrLfCase PROCESSOR_MIPS_R4000msg = msg + "Procesador MIPS R4000." + vbCrLfCase PROCESSOR_ALPHA_21064msg = msg + "Procesador DEC Alpha 21064." + vbCrLfCase Elsemsg = msg + "Procesador (desconocido)." + vbCrLfEnd Selectmsg = msg + vbCrLfDim memsts As MEMORYSTATUSDim memory&GlobalMemoryStatus memstsmemory& = memsts.dwTotalPhysmsg = msg + "Memoria Fisica Total: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLfmemory& = memsts.dwAvailPhysmsg = msg + "Memoria Fisica Disponible: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLfmemory& = memsts.dwTotalVirtualmsg = msg + "Memoria Virtual Total: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLfmemory& = memsts.dwAvailVirtualmsg = msg + "Memoria Virtual Disponible: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLf + vbCrLfMsgBox msg, 0, "Acerca del Sistema"MousePointer = 0EndEnd Sub
Escribir lo siguiente en el módulo:Type SYSTEM_INFOdwOemID As LongdwPageSize As LonglpMinimumApplicationAddress As LonglpMaximumApplicationAddress As LongdwActiveProcessorMask As LongdwNumberOrfProcessors As LongdwProcessorType As LongdwAllocationGranularity As LongdwReserved As LongEnd TypeType OSVERSIONINFOdwOSVersionInfoSize As LongdwMajorVersion As LongdwMinorVersion As LongdwBuildNumber As LongdwPlatformId As LongszCSDVersion As String * 128End TypeType MEMORYSTATUSdwLength As LongdwMemoryLoad As LongdwTotalPhys As LongdwAvailPhys As LongdwTotalPageFile As LongdwAvailPageFile As LongdwTotalVirtual As LongdwAvailVirtual As LongEnd TypeDeclare Function GetVersionEx Lib "kernel32"Alias "GetVersionExA" (LpVersionInformationAs OSVERSIONINFO) As LongDeclare Sub GlobalMemoryStatus Lib "kernel32"(lpBuffer As MEMORYSTATUS)Declare Sub GetSystemInfo Lib "kernel32"(lpSystemInfo As SYSTEM_INFO)Public Const PROCESSOR_INTEL_386 = 386Public Const PROCESSOR_INTEL_486 = 486Public Const PROCESSOR_INTEL_PENTIUM = 586Public Const PROCESSOR_MIPS_R4000 = 4000Public 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 LongPrivate 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 fCreateShellLinkLib "STKIT432.DLL" (ByVal lpstrFolderNameAs String, ByVal lpstrLinkName As String,ByVal lpstrLinkPath As String,ByVal lpstrLinkArgs As String) As LongPrivate 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" (ByValuFlags&, ByVal dwReserved&)Private Sub Command1_Click()Dim i as integeri = ExitWindowsEx(1, 0&) 'Apaga el equipoEnd SubPrivate Sub Command2_Click()Dim i as integeri = ExitWindowsEx(0, 0&) 'Reinicia Windows con nuevo usuarioEnd SubPrivate Sub Command3_Click()Dim i as integeri = ExitWindowsEx(2, 0&) 'Reinicia el SistemaEnd Sub
Borrar un fichero y enviarlo a la papelera de reciclaje:Crear un formulario y escribir el siguiente código:
Private Type SHFILEOPSTRUCThWnd As LongwFunc As LongpFrom As StringpTo As StringfFlags As IntegerfAnyOperationsAborted As BooleanhNameMappings As LonglpszProgressTitle As StringEnd TypePrivate Declare Function SHFileOperation Lib "shell32.dll" Alias"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPrivate Const FO_DELETE = &H3Private Const FOF_ALLOWUNDO = &H40Public Sub PapeleraDeReciclaje(ByVal Fichero As String)Dim SHFileOp As SHFILEOPSTRUCTDim RetVal As LongWith SHFileOp.wFunc = FO_DELETE.pFrom = FileName.fFlags = FOF_ALLOWUNDOEnd WithRetVal = SHFileOperation(SHFileOp)End SubPrivate 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 LongAbrirConexion = 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_DIAL-UP, 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 LongPrivate Sub Form_Load()Dim x As Integer, i As IntegerFor i = 1 To 20List1.AddItem "El número final de la selección es el " & iNext ix = 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 = 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 atimeatime = TimerDo While Timer - atime < Val(interval)DoEventsLoopEnd 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 = 0MensajeSaliente = ""MensajeEntrante = ""If Cfg.FicheroAnexo <> "" ThenOpen NFich For Binary As #3 Len = 3Cont = 0ContTotal = 0Progreso.Max = FileLen(NFich)While Not ContTotal = LOF(3)ContTotal = ContTotal + 1Caracter = Input(1, 3)Cont = Cont + 1Trio(Cont) = Asc(Caracter)'MensajeSaliente = MensajeSaliente + CaracterIf Cont = 3 ThenCuatro(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) * 64MensajeEntrante = 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 = 0ContLinea = ContLinea + 4If ContLinea = 76 ThenMensajeEntrante = MensajeEntrante + vbCrLfContLinea = 0End IfEnd IfDoEventsWendSelect Case ContCase 1Cuatro(1) = Int(Trio(1) / 4)Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1) + "=="Case 2Cuatro(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)) * 4MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1) + "="End SelectClose #3End IfEnd Sub
Nuevo
Para abrir:
Código:Dim foo As Integerfoo = FreeFileOpen "C:\Archivo.txt" For Input As #fooText1.Text = Input(LOF(foo), #foo)Close #foo
Para guardar:
Código:Dim foo As Integerfoo = FreeFileOpen "C:\Archivo.txt" For Output As #fooPrint #foo, Text1.TextClose #foo
dialogos:
Ese es para Abrir
Código:Dim strOpen As StringCommonDialog1.ShowOpenstrOpen = CommonDialog1.FileNameText1.LoadFile strOpenText1.LoadFile strClose
Ese para guardar
Código:Dim strNewFile As StringCommonDialog1.ShowSavestrNewFile = CommonDialog1.FileNameText1.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 LongPrivate Sub Form_Load()Combo1.ClearCombo1.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 SubPrivate Sub Command1_Click()'ComboBox desplegadoDim Resp As LongResp = SendMessageLong(Combo1.hwnd, &H14F, True, 0)End Sub
Nota: Resp = SendMessageLong(Combo1.hwnd, &H14F, False, 0) oculta la lista desplegadade 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 ListBoxa "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 LongPrivate 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 SubPrivate Sub Command1_Click()'Seleccion de todo el contenidoDim Resp As LongResp = SendMessageLong(List1.hwnd, &H185&, True, -1)End SubPrivate Sub Command2_Click()'Eliminacion de todos los elementos seleccionadosDim Resp As LongResp = 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" (ByValhdc As Long, ByVal nIndex As Long) As LongPrivate Declare Function GetDC Lib "user32" (ByVal hwndAs Long) As LongPrivate Declare Function GetDesktopWindow Lib "user32" ()As LongPrivate Sub Form_Load()Dim ObCaps As LongDim ObDC As LongDim ObDesktop As LongDim Cad As StringObDesktop = GetDesktopWindow()ObDC = GetDC(ObDesktop)ObCaps = GetDeviceCaps(ObDC, 88)If ObCaps = 96 Then Cad = "PequeñasIf ObCaps = 120 Then Cad = "Grandes"MsgBox "Fuentes de letra " & CadEnd Sub
*) Esta función ha sido corregida por un error en las etiquetas, 96 corresponde a pequeñasy 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 LongPrivate Sub Form_Load()Dim Resp As LongResp = SetWindowLong(Me.hwnd, -20, &H20&)Form1.RefreshEnd 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 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd SubPrivate Sub Text2_KeyPress(KeyAscii As Integer)If KeyAscii = 13 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd SubPrivate Sub Text3_KeyPress(KeyAscii As Integer)If KeyAscii = 13 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd 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 ThenSendKeys "{tab}"KeyAscii = 0End IfEnd 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 IntegerDim A As StringI = 3A = IIf(I <> 1, "True", "False")Text1.Text = AEnd 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 IntegerText1.Text = UCase(Text1.Text)I = Len(Text1.Text)Text1.SelStart = IEnd 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 LongPrivate 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úsescribir lo siguiente:
Caption -> EditorName -> MnuEditorPulse Insertar y el botón "->"Caption -> AñadirName -> MnuAñadirPulse InsertarCaption -> QuitarName -> MnuQuitarEnabled -> FalsePulse InsertarCaption -> SalirName -> MnuSalirPulse InsertarCaption -> -Name -> MnuIndexIndex -> 0Pulse AceptarEscribir el siguiente código en el formulario:Private ultElem As IntegerPrivate Sub Form_Load()ultElem = 0End SubPrivate Sub MnuQuitar_Click()Unload MnuIndex(ultElem)ultElem = ultElem - 1If ultElem = 0 ThenMnuQuitar.Enabled = FalseEnd IfEnd SubPrivate Sub MnuSalir_Click()EndEnd SubPrivate Sub MnuAñadir_Click()ultElem = ultElem + 1Load MnuIndex(ultElem)MnuIndex(ultElem).Caption = "Menu -> " + Str(ultElem)MnuQuitar.Enabled = TrueEnd 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 AsLong, ByVal lpvParam As Any, ByVal fuWinIni As Long) As LongPrivate Sub Form_Load()Dim fallo As Integerfallo = 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 LongPrivate 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 IntegerFor i = 0 To Form1.ScaleHeight Step Picture1.HeightFor j = 0 To Form1.ScaleWidth Step Picture1.WidthPaintPicture Picture1, j, i, Picture1.Width,Picture1.HeightNextNextEnd SubPrivate Sub Form_Resize()Picture1.Left = -(Picture1.Width + 200)Picture1.Top = -(Picture1.Height + 200)Label1.Top = 100Label1.Left = 100End 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 ExplicitPrivate Declare Function GetDriveType Lib "kernel32" Alias"GetDriveTypeA" (ByVal nDrive As String) As LongPrivate Declare Function GetLogicalDriveStrings Lib "kernel32" Alias"GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVallpBuffer As String) As LongPrivate Const DRIVE_REMOVABLE = 2Private Const DRIVE_FIXED = 3Private Const DRIVE_REMOTE = 4Private Const DRIVE_CDROM = 5Private Const DRIVE_RAMDISK = 6Function StripNulls(startStrg$) As StringDim c%, item$c% = 1DoIf Mid$(startStrg$, c%, 1) = Chr$(0) Thenitem$ = Mid$(startStrg$, 1, c% - 1)startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))StripNulls$ = item$Exit FunctionEnd Ifc% = c% + 1LoopEnd FunctionPrivate Sub Form_Load()Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&Dim CDfound As IntegerallDrives$ = Space$(64)r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)allDrives$ = Left$(allDrives$, r&)Dopos% = InStr(allDrives$, Chr$(0))If pos% ThenJustOneDrive$ = Left$(allDrives$, pos%)allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))DriveType& = GetDriveType(JustOneDrive$)If DriveType& = DRIVE_CDROM ThenCDfound% = TrueExit DoEnd IfEnd IfLoop Until allDrives$ = "" Or DriveType& = DRIVE_CDROMIf CDfound% Thenlabel1.Caption = "La unidad de CD-ROM corresponde a launidad: " & UCase$(JustOneDrive$)Elselabel1.Caption = "Su sistema no posee CD-ROM o unidadno encontrada."End IfEnd 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 LongPrivate Sub Form_Load()Dim col, bit, largo, alto As Integercol = GetDeviceCaps(Form1.hdc, 12)If col = 1 Thenbit = GetDeviceCaps(Form1.hdc, 14)If bit = 1 ThenText1.Text = "Resolucion de 1 bit / 2 colores"ElseIf bit = 4 ThenText1.Text = "Resolucion de 4 bits / 16 colores"End IfElseIf col = 8 ThenText1.Text = "Resolucion de 8 bits / 256 colores"ElseIf col = 16 ThenText1.Text = "Resolucion de 16 bits / 65000 colores"ElseText1.Text = "Resolucion de 16 M colores"End Iflargo = 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 LongPrivate Sub Form_Load()Dim inf As Integerinf = waveOutGetNumDevs()If inf > 0 ThenMsgBox "Tarjeta de sonido soportada.", vbInformation,"Informacion: Tarjeta de sonido"ElseMsgBox "Tarjeta de sonido no soportada.", vbInformation,"Informacion: Tarjeta de sonido"End IfEndEnd 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 StringMousePointer = 11Dim verinfo As OSVERSIONINFOverinfo.dwOSVersionInfoSize = Len(verinfo)ret% = GetVersionEx(verinfo)If ret% = 0 ThenMsgBox "Error Obteniendo Information de la Version"EndEnd IfSelect Case verinfo.dwPlatformIdCase 0msg = msg + "Windows 32s "Case 1msg = msg + "Windows 95 "Case 2msg = msg + "Windows NT "End Selectver_major$ = verinfo.dwMajorVersionver_minor$ = verinfo.dwMinorVersionbuild$ = verinfo.dwBuildNumbermsg = msg + ver_major$ + "." + ver_minor$msg = msg + " (Construido " + build$ + ")" + vbCrLf + vbCrLfDim sysinfo As SYSTEM_INFOGetSystemInfo sysinfomsg = msg + "CPU: "Select Case sysinfo.dwProcessorTypeCase PROCESSOR_INTEL_386msg = msg + "Procesador Intel 386 o compatible." + vbCrLfCase PROCESSOR_INTEL_486msg = msg + "Procesador Intel 486 o compatible." + vbCrLfCase PROCESSOR_INTEL_PENTIUMmsg = msg + "Procesador Intel Pentium o compatible." + vbCrLfCase PROCESSOR_MIPS_R4000msg = msg + "Procesador MIPS R4000." + vbCrLfCase PROCESSOR_ALPHA_21064msg = msg + "Procesador DEC Alpha 21064." + vbCrLfCase Elsemsg = msg + "Procesador (desconocido)." + vbCrLfEnd Selectmsg = msg + vbCrLfDim memsts As MEMORYSTATUSDim memory&GlobalMemoryStatus memstsmemory& = memsts.dwTotalPhysmsg = msg + "Memoria Fisica Total: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLfmemory& = memsts.dwAvailPhysmsg = msg + "Memoria Fisica Disponible: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLfmemory& = memsts.dwTotalVirtualmsg = msg + "Memoria Virtual Total: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLfmemory& = memsts.dwAvailVirtualmsg = msg + "Memoria Virtual Disponible: "msg = msg + Format$(memory& \ 1024, "###,###,###") + "Kb" + vbCrLf + vbCrLfMsgBox msg, 0, "Acerca del Sistema"MousePointer = 0EndEnd Sub
Escribir lo siguiente en el módulo:Type SYSTEM_INFOdwOemID As LongdwPageSize As LonglpMinimumApplicationAddress As LonglpMaximumApplicationAddress As LongdwActiveProcessorMask As LongdwNumberOrfProcessors As LongdwProcessorType As LongdwAllocationGranularity As LongdwReserved As LongEnd TypeType OSVERSIONINFOdwOSVersionInfoSize As LongdwMajorVersion As LongdwMinorVersion As LongdwBuildNumber As LongdwPlatformId As LongszCSDVersion As String * 128End TypeType MEMORYSTATUSdwLength As LongdwMemoryLoad As LongdwTotalPhys As LongdwAvailPhys As LongdwTotalPageFile As LongdwAvailPageFile As LongdwTotalVirtual As LongdwAvailVirtual As LongEnd TypeDeclare Function GetVersionEx Lib "kernel32"Alias "GetVersionExA" (LpVersionInformationAs OSVERSIONINFO) As LongDeclare Sub GlobalMemoryStatus Lib "kernel32"(lpBuffer As MEMORYSTATUS)Declare Sub GetSystemInfo Lib "kernel32"(lpSystemInfo As SYSTEM_INFO)Public Const PROCESSOR_INTEL_386 = 386Public Const PROCESSOR_INTEL_486 = 486Public Const PROCESSOR_INTEL_PENTIUM = 586Public Const PROCESSOR_MIPS_R4000 = 4000Public 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 LongPrivate 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 fCreateShellLinkLib "STKIT432.DLL" (ByVal lpstrFolderNameAs String, ByVal lpstrLinkName As String,ByVal lpstrLinkPath As String,ByVal lpstrLinkArgs As String) As LongPrivate 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" (ByValuFlags&, ByVal dwReserved&)Private Sub Command1_Click()Dim i as integeri = ExitWindowsEx(1, 0&) 'Apaga el equipoEnd SubPrivate Sub Command2_Click()Dim i as integeri = ExitWindowsEx(0, 0&) 'Reinicia Windows con nuevo usuarioEnd SubPrivate Sub Command3_Click()Dim i as integeri = ExitWindowsEx(2, 0&) 'Reinicia el SistemaEnd Sub
Borrar un fichero y enviarlo a la papelera de reciclaje:Crear un formulario y escribir el siguiente código:
Private Type SHFILEOPSTRUCThWnd As LongwFunc As LongpFrom As StringpTo As StringfFlags As IntegerfAnyOperationsAborted As BooleanhNameMappings As LonglpszProgressTitle As StringEnd TypePrivate Declare Function SHFileOperation Lib "shell32.dll" Alias"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPrivate Const FO_DELETE = &H3Private Const FOF_ALLOWUNDO = &H40Public Sub PapeleraDeReciclaje(ByVal Fichero As String)Dim SHFileOp As SHFILEOPSTRUCTDim RetVal As LongWith SHFileOp.wFunc = FO_DELETE.pFrom = FileName.fFlags = FOF_ALLOWUNDOEnd WithRetVal = SHFileOperation(SHFileOp)End SubPrivate 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 LongAbrirConexion = 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_DIAL-UP, 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 LongPrivate Sub Form_Load()Dim x As Integer, i As IntegerFor i = 1 To 20List1.AddItem "El número final de la selección es el " & iNext ix = 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 = 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 atimeatime = TimerDo While Timer - atime < Val(interval)DoEventsLoopEnd 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 = 0MensajeSaliente = ""MensajeEntrante = ""If Cfg.FicheroAnexo <> "" ThenOpen NFich For Binary As #3 Len = 3Cont = 0ContTotal = 0Progreso.Max = FileLen(NFich)While Not ContTotal = LOF(3)ContTotal = ContTotal + 1Caracter = Input(1, 3)Cont = Cont + 1Trio(Cont) = Asc(Caracter)'MensajeSaliente = MensajeSaliente + CaracterIf Cont = 3 ThenCuatro(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) * 64MensajeEntrante = 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 = 0ContLinea = ContLinea + 4If ContLinea = 76 ThenMensajeEntrante = MensajeEntrante + vbCrLfContLinea = 0End IfEnd IfDoEventsWendSelect Case ContCase 1Cuatro(1) = Int(Trio(1) / 4)Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1) + "=="Case 2Cuatro(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)) * 4MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1) + "="End SelectClose #3End IfEnd Sub
No hay comentarios:
Publicar un comentario