[ Arriba ]

Si tienes algún programa interesante, enviamelo y lo colocaré en la lista.CiberStats. Pincha para estadisticas.

EnConstruccion.gif (286 bytes) Curso de TCP/IP Programación de aplicaciones Cliente/Servidor con TCPIP  91K Acceder Raúl Giménez
Correo através de SMTP

Ejemplo para enviar mensajes directamente através del servidor SMTP. El fichero anexado se codifica en base64.

 35 K Descargar Raúl Giménez
Gestión de videos Programa para gestionar los mil videos que "El Giménez" graba diariamente. 232 K Descargar Raúl Giménez
Navegador personalizado Programa que usa los controles de Internet Explorer para hacer un navegador a medida 4 K Descargar IDG
Busca Puertos IP Este programa busca los puertos abiertos de una direccion IP. 3 K Descargar Anonimo
Telnet Servidor y cliente de "telnet" 9 K Descargar Raúl Giménez
Control calendario Control que permite navegar por el calendario de cualquier mes y permite marcar los dias festivo 5 K Descarga Raúl Giménez
Simulacion de una consola MS/DOS Muestra una pantalla con el aspecto de MS/DOS y ejecuta comandos sobre ella. 5 K Descargar Microsoft
Arrastrar y soltar Ejemplo que arrastra elementos de una tabla a otra dentro de una base de datos Access 17K Descargar Raúl Giménez
Aprende API Muestra como usar las API de windows más frecuentes 74 K Descargar Steve Anderson
Aprende API Muestra como usar las API de windows más frecuentes 52 K Descargar Paul Kuliniewicz
Nombre host por IP Programa que busca el nombre de un ordenador por su  IP 9 K Descargar Anonimo
Ping Programa que hace PING usando las API. 7 K Descargar Jim Huff
Codigos de Barras Ejemplo para utilizar codigos de barras 12 K Descargar Listas vb
Cambiar resolución Ejemplo para cambiar la resolución de la pantalla 3 K Descargar Listas vb
Iconos en Stray Ejemplo para hacer un programa y que su icono aparezca en el System Stray. (Parte derecha/abajo de la pantalla) 4 K Descargar Listas vb
Imprimir Pantalla Ejemplo para imprimir la pantalla desde un programa 2 K Descargar Listas vb
Tamaño ficheros Programa que informa del tamaño del fichero seleccionado 9 K Descargar Listas vb
Nombre usuario Programa que te dice el nombre del usuario 4 K Descargar Listas vb
Scaner Twain Programa que utiliza un scaner Twain 13 K Descargar Listas vb
  Scanner Cannon Programa que utiliza un scaner Twain 2 K Descargar Listas vb
  Situar msgbox Ejemplo para situar un msgbox en la pantalla 33 K Descargar Listas vb
  Tocar MP3 Toca la musica en formato MP3 84K Descargar Listas vb
  Formulario Transparente Formulario Transparente 21K Descargar Lista vb
  Areas sensibles Como definir areas dentro de un formulario y ver si el usuario hizo click en alguna 3K Descargar Damian Janowski
  unidades del sistema Muestra que tipos de unidades hay en un equipo (disquetera, HD, CDROM,..) 3K Descargar Lista vb
  Unidades de sistema Permite saber que tipo de unidades hay en un equipo (disquetera, HD, CDROM,..) 2K Descargar Lista vb
  menu emergente Añadir opciones de menu emergente asociadas a una extension 6K Descargar Lista vb
NuevoPequeño.gif (152 bytes) De numero a letras Traduce cantidades numericas a texto. (Para talones...) (hay dos versiones) 7K
3K		 Descargar (1)
Descargar (2)		 Manuel Lopez
Javier Pandani

Trucos:

Problema Solución
Redirección automatica de una web a otra

Hay dos modos para conseguir este efecto: el primero es a través de una etiqueta Meta, a insertar dentro de las etiquetas <head> y </head>:

<META HTTP-EQUIV="Refresh" CONTENT="5; url=http://www.dominio.es/tucuenta/pagina.htm">
donde 5 es el número de segundos que transcurren antes de cargar la dirección especificada.

Otra forma de conseguir el redireccionamiento, es a través de JavaScript: sólo tienes que "copiar y pegar" el siguiente código dentro de las etiquetas <head> y </head>:

<script language="JavaScript">
<!--
function redirecciona(){
   window.top.location.href="http://www.dominio.es/tucuenta/pagina.htm";
}
setTimeout("redirecciona()", 5000);
// -->
</script>

donde 5000 es el número de milisegundos que pasan antes de abrir la nueva página.

¿ Como recibir los articulos de la base de datos de Microsoft? Envia un mensaje a mshelp@microsoft.com indicando en el asunto el numero del articulo que quieres recibir. Por ejemplo, para recibir el articulo Q162721 debes poner "Asunto: Q162721". Si quieres recibir la lista de todos los articulos, debes poner "Asunto: Index"
Saber si el programa ya se esta ejecutando if app.previnstance then msgbox "Ya se esta ejecutando una instancia de este programa"
¿ Como copiar todas las tablas de una base de datos en una destino ? '---Esta rutina sirve para copiar todas las tablas de una base de datos en una destino.
'Si las tablas ya existian en la base de datos de eliminan y se vuelven a crear con
'la misma estructura que tuvieran en origen
'Las tablas de la base destino que no se encuentren en origen no se modifican.
'Si el parametro boCopiarDatos es true (valor por defecto) ademas de
'estructura se copian los datos de las tablas.

Sub CopiaTablas(strOrigen As String, strDestino As String, Optional boCopiarDatos As Boolean = True)
   Dim dbOrigen As Database, dbDestino As Database
   Dim tdOrigen As TableDef, tdDestino As TableDef
   Dim fdOrigen As Field, fdDestino As Field
   Dim idOrigen As Index, idDestino As Index
   Dim prOrigen As Property, prDestino As Properties
   Dim i As Long
  
   Screen.MousePointer = vbHourglass
   '---abrir origen y destino
   Set dbOrigen = OpenDatabase(strOrigen, False)
   Set dbDestino = OpenDatabase(strDestino, True)
   '---hay propiedades que no se pueden copiar como el value de los campos
   On Error Resume Next
   '---para cada tabla de origen
   For Each tdOrigen In dbOrigen.TableDefs
      If (tdOrigen.Attributes And (dbSystemObject Or dbHiddenObject))
      '---si la tabla no es del sistema
      '---mirar si existe la tabla en destino
      For Each tdDestino In dbDestino.TableDefs
         If tdDestino.Name = tdOrigen.Name Then
            '---si existe la borro
            dbDestino.TableDefs.Delete tdDestino.Name
            Exit For
         End If
      Next
      '---creo la tabla en el destino
      Set tdDestino = dbDestino.CreateTableDef(tdOrigen.Name, _
      tdOrigen.Attributes, tdOrigen.SourceTableName, tdOrigen.Connect)
      '---le anado los campos
      For Each fdOrigen In tdOrigen.Fields
         Set fdDestino = tdDestino.CreateField(fdOrigen.Name, _
         fdOrigen.Type, fdOrigen.Size)
         '---copio las propiedades del campo
         For Each prOrigen In fdOrigen.Properties
            fdDestino.Properties(prOrigen.Name) =_
            fdOrigen.Properties(prOrigen.Name)
         Next
         tdDestino.Fields.Append fdDestino
      Next
      '---le anado los indices
      For Each idOrigen In tdOrigen.Indexes
         Set idDestino = tdDestino.CreateIndex(idOrigen.Name)
         '---anado los campos al indice
         For Each fdOrigen In idOrigen.Fields
            Set fdDestino = idDestino.CreateField(fdOrigen.Name
            idDestino.Fields.Append fdDestino
         Next
         '---copio las propiedades del indice
         For Each prOrigen In idDestino.Properties
            idDestino.Properties(prOrigen.Name) =
            idOrigen.Properties(prOrigen.Name)
         Next
         tdDestino.Indexes.Append idDestino
      Next
      dbDestino.TableDefs.Append tdDestino
      '---copio los datos de la tabla, si se solicito
      If boCopiarDatos Then dbOrigen.Execute ("INSERT INTO " + _
         tdDestino.Name + " IN '" + strDestino + "' SELECT * FROM " + tdDesti
      End If
   Next
   '---cerrar origen y destino
   dbOrigen.Close
   dbDestino.Close
   Set dbOrigen = Nothing: Set dbDestino = Nothing
   Set tdOrigen = Nothing: Set tdDestino = Nothing
   Set fdOrigen = Nothing: Set fdDestino = Nothing
   Set idOrigen = Nothing: Set idDestino = Nothing
   Set prOrigen = Nothing: Set prDestino = Nothing
   Screen.MousePointer = vbDefault
End Sub
Esto soluciona lo de las busquedas en los combos y no importa que tantos registros tenga.
 ' para la autobusqueda en los combos
Public Const CB_ERR = -1
Public Const CB_FINDSTRING = &H14C
Public Const CB_FINDSTRINGEXACT = &H158
Public Const CB_GETITEMDATA = &H150
Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWndAs Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any) As Long
'--- luego en el modulo hagan esta subrutina:
Public Sub AutoMatch(cbo As ComboBox, KeyAscii As Integer)
   Dim sBuffer As String
   Dim lRetVal As Longs
   Buffer = Left(cbo.Text, cbo.SelStart) & Chr(KeyAscii)
   lRetVal = SendMessage((cbo.hWnd), CB_FINDSTRING, -1, ByVal sBuffer)
   If lRetVal <> CB_ERR Then
      cbo.ListIndex = lRetVal
      cbo.Text = cbo.List(lRetVal)
      cbo.SelStart = Len(sBuffer)
      cbo.SelLength = Len(cbo.Text)
      KeyAscii = 0
   End If
End Sub
'----por ultimo en el combo con propiedad Style = 0 para que permita escribir,escriben en el evento keypress lo siguiente:
Private Sub Combo2_KeyPress(KeyAscii As Integer)
   AutoMatch Combo2, KeyAscii
End Sub
¿Cómo situar el puntero del ratón
en el centro de un botón y luego "provocar" la pulsación del mismo?		 '------En un módulo
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Private Declare Function PostMessageBynum Lib "user32" Alias "PostMessageA" _
            (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam _
            As Long) As Long 'enviar mensajes al control
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal _
             Y As Long) As Long 'posicionar el puntero del ratón
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
            lpRect As RECT) As Long 'obtener la posición del control
Private Type RECT
         Left As Long
         Top As Long
         Right As Long
         Bottom As Long
End Type

'----- ahora el proceso :
Dim l As Long, PosX As Long, PosY As Long, PosXY As Long
Dim lpRect As RECT

'conocer las posición del botón relativa a la pantalla, en pixels
l = GetWindowRect(Command1.hwnd, lpRect)
'colocar el ratón sobre el centro del botón
PosX = lpRect.Left + ((lpRect.Right - lpRect.Left) / 2)
PosY = lpRect.Top + ((lpRect.Bottom - lpRect.Top) / 2)
l = SetCursorPos(PosX, PosY)
'obtener la posicion del centro del control relativa al propio control,
'en pixels
'no es obligatorio, es para que las coordenadas recibidas en el mousedown
'del control sean coherentes
'la posicion y va en la palabra alta y la x en la baja
PosXY = (PosY - lpRect.Top) * 65536 + (PosX - lpRect.Left)
'simular el click del ratón
l = PostMessageBynum(Command1.hwnd, WM_LBUTTONDOWN, 0&, PosXY)
l = PostMessageBynum(Command1.hwnd, WM_LBUTTONUP, 0&, PosXY)
¿ Como añadir sonido a un programa ? '*** En un módulo:
Public Declare Function sndPlaySound Lib "winmm.dll" _
         Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
         ByVal uFlags As Long) As Long
Public Const SND_LOOP = &H8
Public Const SND_NODEFAULT = &H2
Public Const SND_SYNC = &H0
Public Const SND_ASYNC = &H1
Public Function PlaySound (FileName As String, F As Long) As Long
    PlaySound = sndPlaySound (FileName, F)
End Function

'***Y para llamarla:
PlaySound "C:\Windows\Media\Ding.wav", SND_ASYNC   ' por ejemplo
¿ Como controlar el volumen ? '(archivo MMSYSTEM.DLL para 16bits y WINMM.DLL para 32)

Declare Function waveOutGetVolume Lib "WINMM" (ByVal udeviceid As Integer, lpdwvolume As Long) As Integer
Declare Function waveOutSetVolume Lib "WINMM" (ByVal udeviceid As Integer, ByVal dwVolume As Long) As Integer
Declare Function midiOutSetVolume Lib "WINMM" (ByVal udeviceid As Integer, ByVal dwVolume As Long) As Integer
Declare Function midiOutGetVolume Lib "WINMM" (ByVal udeviceid As Integer, lpdwvolume As Long) As Integer
Declare Function auxOutGetVolume Lib "WINMM" (ByVal udeviceid As Integer, lpdwvolume As Long) As Integer
Declare Function auxOutSetVolume Lib "WINMM" (ByVal udeviceid As Integer, ByVal dwVolume As Long) As Integer
Imprimir un FORM Printer.PrintForm
Imprimir un grafico Clipboard.Clear
MSChart1.EditCopy 'Este pudiera ser tu objeto grafico
Printer.Print ""
Printer.PaintPicture
Clipboard.GetData(), 0, 0
Printer.EndDoc
¿ Como registrar un control ? Ejecutar "REGSVR32 control.ocx"
Esta es la forma de registrarlos manualmente (puede ser OCX, DLL, etc)
¿Como reiniciar Windows?

'------------Declarar esta funcion en un modulo...
Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal dwReserved&)
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
'-----------------------
lresult = ExitWindowsEx(EWX_REBOOT, 0&)   '---- Reinicia el sistema

lresult = ExitWindowsEx(EWX_SHUTDOWN, 0&)   '---- Apaga el sistema
¿ Como cambiar la imagen del escritorio? Private Declare Function SystemParametersInfo Lib "user32" Alias _
    "SystemParametersInfoA" _
    (ByVal uAction As Long, ByVal uParam As Long, _
    ByVal lpvParam As String, ByVal fuWinIni As Long) As Long

    Const SPIF_UPDATEINIFILE = &H1
    Const SPI_SETDESKWALLPAPER = 20
    Const SPI_SETDESKPATTERN = 21
    Const SPIF_SENDWININICHANGE = &H2
    Private N As Long

N = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&,_
"c:\MiDirectorio\MiFichero.bmp", SPIF_SENDWININICHANGE Or SPIF_UPDATEINIFILE)
¿Como deshabilitar el CTRL+ALT+DEL Start a new Standard EXE project. Form1 is created by default.
Add two CommandButton controls (Command1 and Command2) to Form1.
Add the following code to Form1's General Declarations section:
'-----------------------------
Private Const SPI_SCREENSAVERRUNNING = 97&
Private Declare Function SystemParametersInfo Lib "User32" _

Alias "SystemParametersInfoA" _
   (ByVal uAction As Long, _
   ByVal uParam As Long, _
   lpvParam As Any, _
   ByVal fuWinIni As Long) As Long

Private Sub Form_Load()
   Command1.Caption = "Disabled"
   Command2.Caption = "Enabled"
End Sub

Private Sub Form_Unload(Cancel As Integer)
   'Re-enable CTRL+ALT+DEL and ALT+TAB before the program 'terminates.
   Command2_Click
End Sub

Private Sub Command1_Click()
   Dim lngRet As Long
   Dim blnOld As Boolean
   lngRet = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, _
   blnOld, 0&)
End Sub

Private Sub Command2_Click()
   Dim lngRet As Long
   Dim blnOld As Boolean
   lngRet = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, _
   blnOld, 0&)
End Sub

'Press the F5 key to run the program, and click the "Disabled"
'CommandButton. CTRL+ALT+DEL and ALT+TAB are disabled. Click the
'"Enabled" CommandButton to enable CTRL+ALT+DEL and ALT+TAB again.
¿Como detectar si estoy conectado a internet ? ***************************************************************************
' Declaraciones de la API
'***************************************************************************
Option Explicit
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA"_
(lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long

Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA"_
(ByVal hRasCon As Long, lpStatus As Any) As Long

Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32

Public Type RASCONN95
   dwSize As Long
   hRasCon As Long
   szEntryName(RAS95_MaxEntryName) As Byte
   szDeviceType(RAS95_MaxDeviceType) As Byte
   szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
   dwSize As Long
   RasConnState As Long
   dwError As Long
   szDeviceType(RAS95_MaxDeviceType) As Byte
   szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

'***************************************************************************
' DEVUELVE TRUE EN CASO DE ESTAR CONECTADO
' FALSE EN CASO CONTRARIO
'***************************************************************************
Public Function IsConnected() As Boolean

   Dim TRasCon(255) As RASCONN95
   Dim lg As Long
   Dim lpcon As Long
   Dim RetVal As Long
   Dim Tstatus As RASCONNSTATUS95

   TRasCon(0).dwSize = 412
   lg = 256 * TRasCon(0).dwSize
  
   RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
  
   If RetVal <> 0 Then
      MsgBox "ERROR"
      Exit Function
   End If
  
   Tstatus.dwSize = 160
   RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
  
   If Tstatus.RasConnState = &H2000 Then
      IsConnected = True
   Else
      IsConnected = False
   End If
End Function
Desconectarse de internet usando vb '***Declarar en un módulo
Public Const RAS_MAXENTRYNAME As Integer = 256
Public Const RAS_MAXDEVICETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412
Public Const ERR_SUCCESS As Integer = 0
Public Type RasEntryName
      dwSize As Long
      szEntryName(RAS_MAXENTRYNAME) As Byte
End Type
Public Type RasConn
      dwSize As Long
      hRasConn As Long
      szEntryName(RAS_MAXENTRYNAME) As Byte
      szDeviceType(RAS_MAXDEVICETYPE) As Byte
      szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type
Public Declare Function RasEnumConnections Lib _
"rasapi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, _
lpcConnections As Long) As Long
Public Declare Function RasHangUp Lib "rasapi32.dll" Alias _
"RasHangUpA" (ByVal hRasConn As Long)  As Long

Public gstrISPName As String
Public ReturnCode As Long
'******Añadimos estas dos funciones :
Public Sub HangUp()
   Dim i As Long
   Dim lpRasConn(255) As RasConn
   Dim lpcb As Long
   Dim lpcConnections As Long
   Dim hRasConn As Long
   lpRasConn(0).dwSize = RAS_RASCONNSIZE
   lpcb = RAS_MAXENTRYNAME *   lpRasConn(0).dwSize
   lpcConnections = 0
   ReturnCode = RasEnumConnections( lpRasConn(0), lpcb, lpcConnections)
   If ReturnCode = ERROR_SUCCESS Then
      For i = 0 To lpcConnections - 1
         If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then
            hRasConn = lpRasConn(i).hRasConn
            ReturnCode = RasHangUp(ByVal hRasConn)
         End If
      Next i
   End If
End Sub
Public Function ByteToString(bytString() As Byte) As String
   Dim i As Integer
   ByteToString = ""
   i = 0
   While bytString(i) = 0&
      ByteToString = ByteToString & Chr(bytString(i))
      i = i + 1
   Wend
End Function

'***** Y para desconectar debemos hacer sólo :
Call HangUp
¿Como realizar ficheros HLP? Descargar documento word (Autor: Ethan Forme)
¿Como activar el salvapantallas desde vb? Private Declare Function SendMessage Lib "user32" Alias _
  "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
  ByVal wParam As Long, lParam As Long) As Long

Private Sub Command1_Click()
   Call SendMessage(Me.hwnd, &H112, &HF140, 0&)
End Sub
¿ Alinear los iconos del escritorio ? '************************************************************
' Declaraciones de la API para alinear los iconos
************************************************************
Private Declare Function GetWindow Lib "user32"_
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function SendMessage Lib "user32"_
   Alias "SendMessageA" (ByVal hwnd As Long,_
   ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function FindWindow Lib "user32" _
   Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const GW_CHILD = 5
Private Const LVA_ALIGNLEFT = &H1
Private Const LVM_ARRANGE = &H1016
'************************************************************
' Alinear los iconos del escritorio '************************************************************
Las instrucciones para alinear los iconos con
Dim hWnd1 As Long
Dim hWnd2 As Long
Dim Ret As Long
hWnd1 = FindWindow("Progman", vbNullString)
hWnd2 = GetWindow(hWnd1, GW_CHILD)
hWnd1 = GetWindow(hWnd2, GW_CHILD)
Ret = SendMessage(hWnd1, LVM_ARRANGE, LVA_ALIGNLEFT, 0)
¿Como asociar un fichero a un programa determinado ? '************************************************************
'Windows API/Global Declarations for :AssociateFileType '************************************************************
Declare Function RegCreateKey& Lib "advapi32.DLL" Alias "_
    RegCreateKeyA" (ByVal hKey&, ByVal lpszSubKey$, lphKey&)
Declare Function RegSetValue& Lib "advapi32.DLL" _
   Alias "RegSetValueA" (ByVal hKey&, ByVal lpszSubKey$, _
   ByVal fdwType&, ByVal lpszValue$, ByVal dwLength&)
' Return codes from Registration functions.
Public Const ERROR_SUCCESS = 0&
Public Const ERROR_BADDB = 1&
Public Const ERROR_BADKEY = 2&
Public Const ERROR_CANTOPEN = 3&
Public Const ERROR_CANTREAD = 4&
Public Const ERROR_CANTWRITE = 5&
Public Const ERROR_OUTOFMEMORY = 6&
Public Const ERROR_INVALID_PARAMETER = 7&
Public Const ERROR_ACCESS_DENIED = 8&
Global Const HKEY_CLASSES_ROOT = &H80000000
Public Const MAX_PATH = 256&
Public Const REG_SZ = 1
'************************************************************
' RUTINA QUE LE PERMITE ASOCIAR UN DETERMINADO
' TIPO DE FICHERO A UN PROGRAMA
' ASOCIA UN FICHERO CON EL BLOC DE NOTAS
' SE PUEDE CAMBIAR PARA ASOCIAR LOS QUE VD. QUIERA '************************************************************
Public Const ERROR_SUCCESS = 0&
Public Const ERROR_BADDB = 1&
Public Const ERROR_BADKEY = 2&
Public Const ERROR_CANTOPEN = 3&
Public Const ERROR_CANTREAD = 4&
Public Const ERROR_CANTWRITE = 5&
Public Const ERROR_OUTOFMEMORY = 6&
Public Const ERROR_INVALID_PARAMETER = 7&
Public Const ERROR_ACCESS_DENIED = 8&
Global Const HKEY_CLASSES_ROOT = &H80000000
Public Const MAX_PATH = 256&
Public Const REG_SZ = 1

Private Sub Command1_Click()
   Dim sKeyName As String ' NOMBRE DE LA CLAVE A REGISTRAR
   Dim sKeyValue As String ' NOMBRE DEL VALOR A REGISTRAR
   Dim ret& ' ERROR DEVUELTO POR LAS LLAMADAS A LA API
   Dim lphKey& ' HANDLE A LA CREACION DE REGTKEY
   sKeyName = "MyApp"
   sKeyValue = "My Application"
   ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
   ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
   ' CREA UNA ENTRADA EN LA RAIZ LLAMADA .BAR PARA ASOCIALARLA CON "MyApp".
   sKeyName = ".bar" '*
   sKeyValue = "MyApp" '*
   ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
   ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
   ' LINEA DE MANDATO "MyApp".
   sKeyName = "MyApp" '*
   sKeyValue = "notepad.exe %1" '*
   ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
   ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
End Sub
¿Como saber el nombre del PC? (W95/NT) 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
¿Como puedo saber el espacio libre que queda en el disco ? (FAT32) '************************************************************
' LLAMADAS A LA API
'************************************************************
Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
   "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, _
   FreeBytesToCaller As LargeInt, BytesTotal As LargeInt, _
   FreeBytesTotal As LargeInt) As Long
Type LargeInt
   Bytes(0 To 7) As Byte
End Type
'************************************************************************
' DEVUELVE EL ESPACIO LIBRE DE UN DISCO FORMATEADO CON FAT32
'************************************************************************
Function GetFDS(Drive$)
   Dim FreeBytesToCaller As LargeInt
   BytesTotal As LargeInt
   FreeBytesTotal
   As LargeInt
   Dim i%
   GetDiskFreeSpaceEx Drive, FreeBytesToCaller, BytesTotal, FreeBytesTotal
   For i = 0 to 7
      GetFDS = GetFDS + FreeBytesToCaller.Bytes(i) * 2 ^ (8 * i)
   Next i
End Function
Enviar un e-mail usando Outlok Function EnviarCorreo()
    Dim objOutlook As Outlook.Application
    Dim objMailItem As Outlook.MailItem
 
    Set objOutlook = CreateObject("outlook.application")
    Set objMailItem = objOutlook.CreateItem(olMailItem)
    objMailItem.Recipients.Add "billgates@microsoft.com"
    objMailItem.Body = "Enviando e-mail desde Código"
    objMailItem.Attachments.Add "C:\BILL\GATES.BMP"
    objMailItem.Subject = "PRUEBA DE AUTOMATIZACION"
    objMailItem.Send
    objOutlook.Quit
    Set objOutlook = Nothing
End Function
¿ Como hacer una ventana siempre visible ? 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)
Public Const HWND_TOPMOST& = -1
Public Const SWP_NOMOVE& = &H2
Public Const SWP_NOSIZE& = &H1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Public Sub ShowHoldForm(Ventana As Form)
   Dim Success
   '****  Para las ventanitas que quedan por encima de las demás,   ****
   Success = SetWindowPos(Ventana.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
End Sub
'-----------------------------
ShowHoldForm Form1
¿Como copiar ficheros y que aparezcan los "papeles volando" ? Private Sub Form_Activate()
   Dim result As Long
   Dim fileop As SHFILEOPSTRUCT
   Form1.Hide
   With fileop
       .hwnd = Me.hwnd
       .wFunc = FO_COPY
       .pFrom = "t:\programs\gestion\gestion.exe" & vbNullChar & vbNullChar
       .pTo = "c:\calipso" & vbNullChar & vbNullChar
       .fFlags = FOF_SIMPLEPROGRESS Or FOF_FILESONLY
   End With
   result = SHFileOperation(fileop)
   If result <> 0 Then
       MsgBox "Operación cancelada"
   Else
       If fileop.fAnyOperationsAborted <> 0 Then
           MsgBox "Operación fallida"
       End If
   End If
   Unload Form1
End Sub
' Para que no pregunte si se quiere sustituir el fichero destino, en caso de que exista, añadir FOF_NOCONFIRMATION en la propiedad .fFlags = FOF_SIMPLEPROGRESS Or
FOF_FILESONLY Or FOF_NOCONFIRMATION

Esta página se actualizó por última vez el martes 06 de febrero de 2001

1