api

Descargar ficheros de Internet

Aquí tenéis el código de un ejemplo para descargar ficheros de Internet, en este caso se baja el fichero Contaplus.zip que esta en la dirección http://descarga.e-mision.net/contaplus.zip y se graba en c:.

Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
    (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
    Dim lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
    If lngRetVal = 0 Then DownloadFile = True
End Function
Private Sub Form_Load()
    If DownloadFile("http://descarga.e-mision.net/contaplus.zip", "c:contaplus.zip") Then
        MsgBox "Descarga completada correctamente", vbInformation
    Else
        MsgBox "La descarga no ha sido completada", vbCritical
    End If
End Sub

Si el servidor requiere inicio de sesión, utiliza el formato “http://usuario:contraseña@www…”, por ejemplo

DownloadFile("http://usuario:contraseña@descarga.e-mision.net/contaplus.zip", "c:contaplus.zip")

Seleccionar equipos y carpetas de una red Windows

Este código muestra un cuadro de dialogo para poder seleccionar sólo un equipo de la red o para seleccionar una carpeta concreta de un equipo que este conectado a la red.

Para ejecutar este ejemplo debes añadir al nuevo proyecto dos botones (Command1 y Command2) y dos textbox (Text1 y Text2).

Option Explicit On
Private Const ERROR_SUCCESS As Long = 0
Private Const MAX_PATH As Long = 260
Private Const CSIDL_NETWORK As Long = &H12
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000

Private Type BROWSEINFO
   hOwner As Long
   pidlRoot As Long
   pszDisplayName As String
   lpszTitle As String
   ulFlags As Long
   lpfn As Long
   lParam As Long
   iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   Alias "SHGetPathFromIDListA" _
  (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
   Alias "SHBrowseForFolderA" _
  (ByVal lpBrowseInfo As BROWSEINFO) As Long

Private Declare Function SHGetSpecialFolderLocation _
   Lib "shell32.dll" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   ByVal pidl As Long) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
   (ByVal pv As Long)
Private Sub Command1_Click()
    Text1.Text = GetBrowseNetworkWorkstation()
End Sub
Private Sub Command2_Click()
    Text2.Text = GetBrowseNetworkShare()
End Sub
Private Function GetBrowseNetworkShare() As String
    'returns only a valid share on a
    'network server or workstation
    Dim BI As BROWSEINFO
    Dim pidl As Long
    Dim sPath As String
    Dim pos As Integer

    'obtain the pidl to the special folder 'network'
    If SHGetSpecialFolderLocation(Me.hWnd, _
                                 CSIDL_NETWORK, _
                                 pidl) = ERROR_SUCCESS Then

        'fill in the required members, limiting the
        'Browse to the network by specifying the
        'returned pidl as pidlRoot
        With BI
            .hOwner = Me.hWnd
            .pidlRoot = pidl
            .pszDisplayName = Space$(MAX_PATH)
            .lpszTitle = "Select a network computer or share."
            .ulFlags = BIF_RETURNONLYFSDIRS
        End With

        'show the browse dialog
        pidl = SHBrowseForFolder(BI)
        If pidl  0 Then
            'got a pidl .. but is it valid?
            sPath = Space$(MAX_PATH)
            If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then
                'valid, so get the share path
                pos = InStr(sPath, Chr$(0))
                GetBrowseNetworkShare = Left$(sPath, pos - 1)
            End If
            Call CoTaskMemFree(pidl)
        Else
            'a server selected...follow same principle
            'as in GetBrowseNetworkWorkstation
            GetBrowseNetworkShare = "" & BI.pszDisplayName
        End If  'If pidl
    End If  'If SHGetSpecialFolderLocation
End Function
Private Function GetBrowseNetworkWorkstation() As String
    'returns only a valid network server or
    'workstation (does not display the shares)
    Dim BI As BROWSEINFO
    Dim pidl As Long
    Dim sPath As String
    Dim pos As Integer

    'obtain the pidl to the special folder 'network'
    If SHGetSpecialFolderLocation(Me.hWnd, _
                                 CSIDL_NETWORK, _
                                 pidl) = ERROR_SUCCESS Then

        'fill in the required members, limiting the
        'Browse to the network by specifying the
        'returned pidl as pidlRoot
        With BI
            .hOwner = Me.hWnd
            .pidlRoot = pidl
            .pszDisplayName = Space$(MAX_PATH)
            .lpszTitle = "Select a network computer."
            .ulFlags = BIF_BROWSEFORCOMPUTER
        End With

        'show the browse dialog. We don't need
        'a pidl, so it can be used in the If..then directly.
        If SHBrowseForFolder(BI)  0 Then
            'a server was selected. Although a valid pidl
            'is returned, SHGetPathFromIDList only return
            'paths to valid file system objects, of which
            'a networked machine is not. However, the
            'BROWSEINFO displayname member does contain
            'the selected item, which we return
            GetBrowseNetworkWorkstation = "" & BI.pszDisplayName
        End If  'If SHBrowseForFolder
        Call CoTaskMemFree(pidl)
    End If  'If SHGetSpecialFolderLocation
End Function

Publicado en microsoft.public.es.vb por chincho

Obtener el símbolo monetario existente en la configuración regional de Windows

Inicia un nuevo proyecto, pega el siguiente código en la sección «Declaraciones» y ejecútalo, te mostrara en un MsgBox el Símbolo monetario.

Option Explicit On
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, _ ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long 
Private Const LOCALE_SCURRENCY = &H14
' Constante para el símbolo monetario 
Private Const LOCALE_USER_DEFAULT = &H400
Private Sub Form_Load()
    Dim sBuffer As String Dim dl As Long ' Area intermedia dónde se cargará la información 
    sBuffer = String$(100, vbNullChar)
    ' La función devolverá la cantidad de caracteres 
    ' cargados en el área intermedia. Cero, en caso 
    ' de error. 
    dl = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SCURRENCY, sBuffer, 100)
    If dl  0 Then MsgBox(Left(sBuffer, dl - 1))
End Sub

Publicado en microsoft.public.es.vb por Softjaen

Obtener la hora del Sistema (milisegundos incluidos)

Con esta función API puedes recuperar la hora actual, incluidos los milisegundos.

 

Option Explicit On
Private Declare Sub GetSystemTime Lib "kernel32" (ByVal lpSystemTime As SYSTEMTIME)
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Sub Form_Load()
    Dim SysTime As SYSTEMTIME
    Dim TxtTmp As String

    ' Obtenemos la información del Sistema
    GetSystemTime(SysTime)
    TxtTmp = "Muestra la Fecha y Hora del Sistema" & vbCrLf & vbCrLf
    TxtTmp = TxTTmp & "Fecha: " & SysTime.wDay & "/" & SysTime.wMonth & "/" & SysTime.wYear & vbCrLf
    TxtTmp = TxtTmp & "Hora: " & SysTime.wHour & ":" & SysTime.wMinute & ":" & SysTime.wSecond & ":" & SysTime.wMilliseconds

    ' Mostramos la información. 
    MsgBox(TxtTmp)
End Sub

Obtener la ubicación de las carpetas del sistema

Con esta función API puedes recuperar la ubicación de la situación, en el sistema donde esta corriendo tu aplicación, de las carpetas del sistema, como el Escritorio, Impresoras, Fuentes, Favoritos, Etc…

Copia este ejemplo en un formulario:

Option Explicit On
' Definimos las constantes de las carpetas 
Const CSIDL_DESKTOP = &H0
Const CSIDL_PROGRAMS = &H2
Const CSIDL_CONTROLS = &H3
Const CSIDL_PRINTERS = &H4
Const CSIDL_PERSONAL = &H5
Const CSIDL_FAVORITES = &H6
Const CSIDL_STARTUP = &H7
Const CSIDL_RECENT = &H8
Const CSIDL_SENDTO = &H9
Const CSIDL_BITBUCKET = &HA
Const CSIDL_STARTMENU = &HB
Const CSIDL_DESKTOPDIRECTORY = &H10
Const CSIDL_DRIVES = &H11
Const CSIDL_NETWORK = &H12
Const CSIDL_NETHOOD = &H13
Const CSIDL_FONTS = &H14
Const CSIDL_TEMPLATES = &H15
Const MAX_PATH = 260
Private Type SHITEMID
    cb As Long 
    abID As Byte 
End Type 
Private Type ITEMIDLIST 
    mkid As SHITEMID 
End Type 
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, _
    ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, _
    ByVal nFolder As Long, ByVal pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Sub Form_Load()
    ' Activamos el grafico persistente en el formulario 
    Me.AutoRedraw = True
    ' Mostramos la información en el formulario 
    ' Algunas carpetas devolvera vacio en función del sistema en el que trabajeis 
    Me.Print("Carpeta Desktop..........: " + CarpetadelSistema(CSIDL_DESKTOP))
    Me.Print("Carpeta Programs.........: " + CarpetadelSistema(CSIDL_PROGRAMS))
    Me.Print("Carpeta Controls.........: " + CarpetadelSistema(CSIDL_CONTROLS))
    Me.Print("Carpeta Printers.........: " + CarpetadelSistema(CSIDL_PRINTERS))
    Me.Print("Carpeta Personal.........: " + CarpetadelSistema(CSIDL_PERSONAL))
    Me.Print("Carpeta Favorites........: " + CarpetadelSistema(CSIDL_FAVORITES))
    Me.Print("Carpeta Star UP..........: " + CarpetadelSistema(CSIDL_STARTUP))
    Me.Print("Carpeta Recent...........: " + CarpetadelSistema(CSIDL_RECENT))
    Me.Print("Carpeta Send To..........: " + CarpetadelSistema(CSIDL_SENDTO))
    Me.Print("Carpeta Bit Bucket.......: " + CarpetadelSistema(CSIDL_BITBUCKET))
    Me.Print("Carpeta Start Menu.......: " + CarpetadelSistema(CSIDL_STARTMENU))
    Me.Print("Carpeta Desktop Directory: " + CarpetadelSistema(CSIDL_DESKTOPDIRECTORY))
    Me.Print("Carpeta Drivers..........: " + CarpetadelSistema(CSIDL_DRIVES))
    Me.Print("Carpeta Network..........: " + CarpetadelSistema(CSIDL_NETWORK))
    Me.Print("Carpeta Net Hood.........: " + CarpetadelSistema(CSIDL_NETHOOD))
    Me.Print("Carpeta Fonts............: " + CarpetadelSistema(CSIDL_FONTS))
    Me.Print("Carpeta Templates........: " + CarpetadelSistema(CSIDL_TEMPLATES))
End Sub
Private Function CarpetadelSistema(ByVal CSIDL As Long) As String
    Dim Res As Long, Camino As String, IDL As ITEMIDLIST
    ' Obtenemos el controlador del sistema 
    Res = SHGetSpecialFolderLocation(100, CSIDL, IDL)
    If Res = 0 Then
        'Creamos el buffer 
        Camino = Space$(512)
        'Obtenermos el camino de IDList 
        Res = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Camino) 
        ' Eliminamos los caracteres Chr(0) 
        CarpetadelSistema = Left$(Camino, InStr(Camino, Chr$(0)) - 1)
        Exit Function
    End If
    CarpetadelSistema = ""
End Function

Asignar la hora actual al sistema

Con esta función API puedes actualizar la hora del sistema completando los datos del tipo SYSTEMTIME, la declaración sería.

Private Declare Function SetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) As Long
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Un ejemplo:

Dim HoraSistema As SYSTEMTIME
Dim FechaActual As Date
Dim lReturn As Long

' Una fecha al azar
FechaActual = CDate(#12/1/2003 4:45:23 AM#)

' Ahora preparamos los datos para actualizar el reloj del sistema
With HoraSistema
    .wYear = DatePart("yyyy", FechaActual)
    .wMonth = DatePart("m", FechaActual)
    .wDay = DatePart("d", FechaActual)
    .wHour = DatePart("h", FechaActual)
    .wMinute = DatePart("n", FechaActual)
    .wSecond = DatePart("s", FechaActual)
    .wMilliseconds = 0
End With
' Asignamos la hora al sistema
lReturn = SetSystemTime(HoraSistema)

Hacer PING desde código Visual Basic.

El Winsock maneja protocolos, no es una herramienta que cubre necesidades puntuales. Prueba esta API que maneja el protocolo ICMP.

Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, _ 
    ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, _ 
    ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long 

Publicado en microsoft.public.es.vb por foreback

Cómo crear un DSN mediante código VB.

Este ejemplo genera en el registro de windows la entrada necesaria para crear un DSN desde el código de nuestro programa. Este código es fácil de trasladar a otros lenguajes, ya que sólo hay que tocar el registro.

Option Explicit
Private Const REG_SZ = 1    'Constant for a string variable type.
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, _
   ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, _
   ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
   ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Sub Command1_Click()
   Dim DataSourceName As String
   Dim DatabaseName As String
   Dim Description As String
   Dim DriverPath As String
   Dim DriverName As String
   Dim LastUser As String
   Dim Regional As String
   Dim Server As String
   Dim lResult As Long
   Dim hKeyHandle As Long   'Specify the DSN parameters.
   DataSourceName = ""
   DatabaseName = ""
   Description = ""
   DriverPath = ""
   LastUser = ""
   Server = ""
   DriverName = "SQL Server"   'Create the new DSN key.

   'Set the values of the new DSN key.
   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWAREODBCODBC.INI" & DataSourceName, hKeyHandle)
   lResult = RegSetValueEx(hKeyHandle, "Database", 0&, REG_SZ, ByVal DatabaseName, Len(DatabaseName))
   lResult = RegSetValueEx(hKeyHandle, "Description", 0&, REG_SZ, ByVal Description, Len(Description))
   lResult = RegSetValueEx(hKeyHandle, "Driver", 0&, REG_SZ, ByVal DriverPath, Len(DriverPath))
   lResult = RegSetValueEx(hKeyHandle, "LastUser", 0&, REG_SZ, ByVal LastUser, Len(LastUser))
   lResult = RegSetValueEx(hKeyHandle, "Server", 0&, REG_SZ, ByVal Server, Len(Server))
   'Close the new DSN key.
   lResult = RegCloseKey(hKeyHandle)

   'Open ODBC Data Sources key to list the new DSN in the ODBC Manager.
   'Specify the new value.   'Close the key.
   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWAREODBCODBC.INIODBC Data Sources", hKeyHandle)
   lResult = RegSetValueEx(hKeyHandle, DataSourceName, 0&, REG_SZ, ByVal DriverName, Len(DriverName))
   lResult = RegCloseKey(hKeyHandle)
End Sub

Publicado en microsoft.public.es.vb por Roberto Carretero

Implementar y Destruir Timer con API´s

Con estas funciones podrás crear Timers que no se detendrán con un MsgBox.

Para Crear el Timer

Declare Function SetTimer Lib "User32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long 

Y esta otra para Destruirlo

Declare Function KillTimer Lib "User32" (ByVal hWnd As Long, nIDEvent As Long) As Long