api

Iniciar o finalizar el Salvapantallas de Windows.

Con estas dos funciones puedes activar o desactivar el Salvapantallas.

Para realizar este proyecto debes crear un formulario con 2 botones, uno “Habilitar” y otro “Deshabilitar”.

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
Const SPI_SETSCREENSAVEACTIVE = 17
Private Sub DesHabilitar_Click()
    Dim lngRet As Long
    lngRet = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, True, 0, 0)
End Sub

Private Sub Habilitar_Click()
    Dim lngRet As Long
    lngRet = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, False, 0, 0)
End Sub
Anuncios

Permite incluir fuentes (.ttf) en el sistema.

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Function IncluirTTF(Fichero As String) As Boolean
    ' Incluye en el sistema un fichero TTF
    ' Parametros: Fichero ruta completa donde se encuentra el fichero origen
    Dim X As Long
    
    X = AddFontResource(Fichero)
        
    ' La función devuelve :
    ' True : Si todo fue correcto.
    ' False : Si hubo algún problema.
    IncluirTTF = IIf(X = 0, False, True)
End Function

Con esta API podrás incluir automáticamente las fuentes que tu programa usa, para que Windows las reconozca y pueda utilizarlas.

Permite interactuar con la propiedades de la barra de tareas

Con esta API podrás cambiar las opciones ‘Siempre Visible’ y ‘Ocultar Automáticamente’ de la barra de tareas de Windows, también podrás conocer sus coordenadas.

Const ABS_AUTOHIDE = &H1
Const ABS_ONTOP = &H2
Const ABM_GETSTATE = &H4
Const ABM_GETTASKBARPOS = &H5
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type APPBARDATA
    cbSize As Long
    hwnd As Long
    uCallbackMessage As Long
    uEdge As Long
    rc As RECT
    lParam As Long '  message specific
End Type
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, _
                 pData As APPBARDATA) As Long
Private Sub Form_Paint()
    'KPD-Team 1999
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    Dim ABD As APPBARDATA, Ret As Long
    'Get the taskbar's position
    SHAppBarMessage ABM_GETTASKBARPOS, ABD
    'Get the taskbar's state
    Ret = SHAppBarMessage(ABM_GETSTATE, ABD)
    If (Ret And ABS_AUTOHIDE) Then Me.Print "Autohide option is on"
    If (Ret And ABS_ONTOP) Then Me.Print "Always on top option is on"
    Me.Print "Taskbar coordinates: (" + Trim(Str(ABD.rc.Left)) + "," + _
             Trim(Str(ABD.rc.Top)) + ")-(" + Trim(Str(ABD.rc.Right)) + _
             "," + Trim(Str(ABD.rc.Bottom)) + ")"
End Sub

Publicado en es.comp.lenguajes.visual-basic por Mindeye

Detectar aplicaciones activas en Windows

El objetivo del módulo es saber en todo momento cuando un programa se está ejecutando o ha terminado la ejecución y qué se está ejecutando.

Option Explicit

Public colFicActivos As New Collection
Type PROCESSENTRY32
   dwSize              As Long
   cntUsage            As Long
   th32ProccessID      As Long
   th32DefaultHeapId   As Long
   th32ModuleID        As Long
   cntThreads          As Long
   th32ParentProcessID As Long
   pcPriClassBase      As Long
   dwFlags             As Long
   szExeFile           As String * 260
End Type

Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" _
      (ByVal lFlags As Long, ByVal lProccessID As Long) As Long

Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" _
      (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" _
      (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
    
Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)

' Guarda los ficheros activos en una colección
Sub cargaFicherosActivos()    
    Dim hSnapShot   As Long
    Dim uProceso    As PROCESSENTRY32
    Dim res         As Long
    Dim i           As Integer
    '//Vaciar colección
    While colFicActivos.Count > 0
        colFicActivos.Remove 1
    Wend
    i = 0
    hSnapShot = CreateToolhelpSnapshot(2&, 0&)
    If hSnapShot  0 Then
        uProceso.dwSize = Len(uProceso)
        res = ProcessFirst(hSnapShot, uProceso)
        '//Ir guardando elementos
        Do While res
            colFicActivos.Add Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1), CStr(i)
            res = ProcessNext(hSnapShot, uProceso)
            i = i + 1
        Loop
        Call CloseHandle(hSnapShot)
    End If    
End Sub

' Busca una cadena contenida en cualquier fichero que está activo
Function LookFicheroLike(strFicheroComp As String) As Boolean
    LookFicheroLike = False
    Dim i As Integer
    For i = 1 To colFicActivos.Count
        If InStr(UCase$(colFicActivos(i)), UCase$(strFicheroComp)) Then
            LookFicheroLike = True
        End If
    Next i
End Function

' Busca el nombre de un fichero(sin ruta) y sin extensión(opcional)
Function LookExisteFichero(strFicheroComp As String, Optional booExtension) As Boolean
    LookExisteFichero = False
    Dim i As Integer
    For i = 1 To colFicActivos.Count
        '// Eliminamos la ruta
        Dim strActivo   As String
        Dim strFichero As String
        Dim strCaracter As String
        Dim r           As Integer
        strFichero = ""
        strActivo = UCase$(colFicActivos(i))
        r = Len(strActivo)
        strCaracter = ""
        While strCaracter  ""
            strCaracter = Mid$(strActivo, r, 1)
            r = r - 1
        Wend
        strFichero = Right$(strActivo, Len(strActivo) - (r + 1))
        '// Si recibe el segundo parametro quita la extensión
        If Not IsMissing(booExtension) Then
            strFichero = Left$(strFichero, InStr(strFichero, ".") - 1)
        End If
        '// Se comparan
        'MsgBox strFichero
        If strFichero = UCase$(strFicheroComp) Then
            LookExisteFichero = True
        End If
    Next i
End Function

Publicado en es.comp.lenguajes.visual-basic por Ricardo

Cómo mostrar un error de forma detallada al llamar a un API.

La mayor parte de las APIs de 32 bits retornan información detallada sobre el error producido en caso de fallo. Para obtener esta información en un formato adecuado y útil, se pueden utilizar las funciones de la API GetLastError y FormatMessage.

Cuando quieras comprobar el error que ha producido una función API usa lo siguiente:

MsgBox InformacionError

Aquí tienes el código de La función InfErrorAPI:

Option Explicit
Public Declare Function GetLastError Lib "kernel32" () As Long
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _
   ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Function InfErrorAPI() As String
    Dim sError As String * 500
    Dim lErrNum As Long, lErrMsg As Long
    
    ' Obtenemos el Código del último error producido
    lErrNum = GetLastError
    ' Obtenemos el texto aclaratorio del error
    lErrMsg = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, lErrNum, 0, sError, Len(sError), 0)
    InfErrorAPI = Format(lErrNum) & ": " & Trim(sError)
End Function

Transforma el formulario y se encarga de seguir el contorno de una imagen dada.

Este código va en el Formulario.

Option Explicit
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Type T_Size
        x As Long
        y As Long
End Type
Dim Mover As Boolean
Dim AuxX As Integer
Dim AuxY As Integer
Dim File As String
Dim Size As T_Size
 
Private Sub Check2_Click()
   If Check2.Value = vbChecked Then
      Command1.Visible = False
      Command2.Visible = False
      Command3.Visible = False
      Command4.Visible = False
      Command5.Visible = False
      Check1.Visible = False
      Label1.Visible = False
      Label2.Visible = False
      Label3.Visible = False
      Label4.Visible = False
      Text1.Visible = False
      Text2.Visible = False
   Else
      Command1.Visible = True
      Command2.Visible = True
      Command3.Visible = True
      Command4.Visible = True
      Command5.Visible = True
      Check1.Visible = True
      Label1.Visible = True
      Label2.Visible = True
      Label3.Visible = True
      Label4.Visible = True
      Text1.Visible = True
      Text2.Visible = True
   End If
End Sub
 
Private Sub Command1_Click()
   Dim x As Integer
   Dim y As Integer
   Dim Sx As Integer
   Dim Sy As Integer
   Dim hRgn As Long
   Dim Hrgn1 As Long
   Dim Col As Long
   Dim Ay As Integer
   Dim Sw As Integer
   Dim Step As Integer
   Dim DifY As Integer
   Dim DifX As Integer
   Dim Total As Double
   Dim C As Double
   Dim W As Double
   
   If File  "" Then
      Step = Val(Text2.Text)
      DifY = Principal.Height - Principal.ScaleHeight
      DifX = Principal.Width - Principal.ScaleWidth
      Sx = Screen.TwipsPerPixelX
      Sy = Screen.TwipsPerPixelY
      Principal.PaintPicture LoadPicture(File), 0, 0
      hRgn = CreateRectRgn(0, 0, Principal.Width / Sx, Principal.Height / Sy)
      Total = Int(((Principal.Width + Step) / Step) * ((Principal.Height + Step) / Step) + ((Principal.Width + 100) / Step) + (Principal.Height / Step))
      C = 0
      Label4.BackStyle = 1
      W = 1425
      Label4.Width = 0
      For x = 0 To Principal.Width + Step Step Step
         C = C + 1
         Ay = 0
         Sw = 0
         For y = 0 To Principal.Height + Step Step Step
               C = C + 1
            Col = Principal.Point(x, y)
            If Col  Val(Text1.Text) And Sw = 0 Then
               Hrgn1 = CreateRectRgn((x + DifX - Step / 2) / Sx, (Ay + DifY) / Sy, (x + DifX + Step / 2) / Sx, (y + DifY) / Sy)
               CombineRgn hRgn, Hrgn1, hRgn, 3
               Sw = 1
            End If
            If Col = Val(Text1.Text) And Sw = 1 Then
               Ay = y
               Sw = 0
            End If
         Next y
         Hrgn1 = CreateRectRgn((x + DifX - Step / 2) / Sx, (Ay + DifY) / Sy, (x + DifX + Step / 2) / Sx, (y + DifY) / Sy)
         CombineRgn hRgn, Hrgn1, hRgn, 3
         Label2.Caption = Int(Val(C * 100 / Total))
         Label4.Width = Val(((C * 100 / Total) * W) / 100)
         DoEvents
      Next x
      SetWindowRgn Principal.hWnd, hRgn, True
      Label2.Caption = ""
      Label4.BackStyle = 0
      Label4.Width = W
      MsgBox "Listo." & Chr(13) & "Se ha aplicado la mascara.", vbOKOnly + vbInformation, "AmA Mascaras"
   End If
End Sub
 
Private Sub Command2_Click()
   cdialog.ShowOpen
   File = cdialog.FileName
   If File  "" Then
      Principal.Cls
      Image1.Picture = LoadPicture(File)
      Size.x = Image1.Width
      If Size.x < 1515 Then Size.x = 1515
      Size.y = Image1.Height
      If Size.y < 2925 Then Size.y = 2925
      Principal.Move Principal.Left, Principal.Top, Size.x, Size.y
      Principal.PaintPicture LoadPicture(File), 0, 0
   End If
End Sub
 
Private Sub Command3_Click()
   Dim Sx As Integer
   Dim Sy As Integer
   Dim hRgn As Long
   
   Sx = Screen.TwipsPerPixelX
   Sy = Screen.TwipsPerPixelY
   hRgn = CreateRectRgn(0, 0, Principal.Width / Sx, Principal.Height / Sy)
   SetWindowRgn Principal.hWnd, hRgn, True
End Sub
 
Private Sub Command4_Click()
   End
End Sub
 
Private Sub Command5_Click()
    Principal.Cls
End Sub
 
Private Sub Form_KeyPress(KeyAscii As Integer)
   Select Case KeyAscii
   Case vbKeyA, 97:
      Command1_Click
   Case vbKeyS, 115:
      Command2_Click
   Case vbKeyD, 100:
      Command3_Click
   Case vbKeyG, 103:
      Command4_Click
   Case vbKeyF, 102:
      If Check2.Value = vbChecked Then
         Check2.Value = vbUnchecked
      Else
         Check2.Value = vbChecked
      End If
   Case vbKeyH, 104:
      Check1.Value = vbChecked
    Case vbKeyJ, 106:
      Command5_Click
   End Select
End Sub
 
Private Sub Form_Load()
   Principal.BackColor = Val(Text1.Text)
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Mover = True
   AuxX = x
   AuxY = y
   If Check1.Value = vbChecked Then
      Text1.Text = Principal.Point(x, y)
      Principal.BackColor = Val(Text1.Text)
      If File  "" Then
         Principal.PaintPicture LoadPicture(File), 0, 0
      End If
      Check1.Value = vbUnchecked
   End If
End Sub
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   If Mover = True Then
      Principal.Left = Principal.Left + x - AuxX
      Principal.Top = Principal.Top + y - AuxY
      DoEvents
   End If
End Sub
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Mover = False
End Sub

Colaboración enviada por Manuel

Cancela todas las conexión RAS que están activas.

Este código va en el Formulario.

Option Explicit
Private Sub Form_Click()
    TerminateRAS
End Sub

Y este otro en un módulo.

Option Explicit

Private 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 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 ERROR_SUCCESS = 0

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 

Sub TerminateRAS()
    ' Cancela todas las conexiones RAS
    Dim i As Long
    Dim RasConn(255) As RasConn
    Dim structSize As Long
    Dim ConnectionsCount As Long
    Dim ret As Long

    'Fills the RasConn structure with the data of all the opened RAS connections
    RasConn(0).dwSize = RAS_RASCONNSIZE
    structSize = RAS_MAXENTRYNAME * RasConn(0).dwSize
    ret = RasEnumConnections(RasConn(0), structSize, ConnectionsCount)
    'hangup all the RAS connections
    If ret = ERROR_SUCCESS Then
        For i = 0 To ConnectionsCount - 1
            ret = RasHangUp(RasConn(i).hRasConn)
        Next
    End If
End Sub

Enviado por Andrea Tincani

Obtiene el Nombre del Controlar de Dominio Primario para un Dominio Especificado o Estación de Trabajo

Este código va en el Formulario.

Option Explicit
Private Sub Form_Click()
    MsgBox GetPDCName("", "")
End Sub

Y este otro en un módulo.

Option Explicit

' La función NetGetDCName obtiene el nombre del Control Primario de Dominio (PDC) 
' de un dominio especificado.
Private Declare Function NetGetDCName Lib "netapi32" (ServerName As Any, DomainName As Any, _
            lpBuffer As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" (ByVal pBuffer As Long) As Long

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, _
            ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long

Private Const NERR_Success As Long = 0&

Private Function PtrToString(lpwString As Long) As String
    ' Convierte el puntero en una cadena
    Dim Buffer() As Byte
    Dim nLen As Long

    If lpwString Then
        nLen = lstrlenW(lpwString) * 2
        If nLen Then
            ReDim Buffer(0 To (nLen - 1)) As Byte
            CopyMem Buffer(0), ByVal lpwString, nLen
            PtrToString = Buffer
        End If
    End If
End Function
Public Function GetPDCName(ComputerName As String, DomainName As String) As String
    ' ComputerName
    ' Contiene el nombre del servidor remoto, devuelve NULL si es el ordenador local.

    'DomainnNme
    ' Contiene el nombre del dominio, devuelve NULL indicando que la función devuelve el
    ' nombre Controlador de Dominio Primario.

    Dim bComputer() As Byte
    Dim bDomain() As Byte
    Dim ret As Long
    Dim lpBuffer As Long
    Dim s As String

    If Trim(ComputerName) = "" Then
        'Local users
        bComputer = vbNullChar
    Else
        'Check the syntax of the ServerName string
        If InStr(ComputerName, "") = 1 Then
            bComputer = ComputerName & vbNullChar
        Else
            bComputer = "" & ComputerName & vbNullChar
        End If
    End If
    If Trim(DomainName) = "" Then
        'Default Domain
        bDomain = vbNullChar
    Else
        bDomain = DomainName & vbNullChar
    End If
    ret = NetGetDCName(bComputer(0), bDomain(0), lpBuffer)
    If ret = NERR_Success And lpBuffer Then
        s = PtrToString(lpBuffer)
    End If
    If lpBuffer Then
        Call NetApiBufferFree(lpBuffer)
    End If
    GetPDCName = s
End Function

Calcula el tiempo que las conexiones RAS están activas

Crea un Nuevo proyecto y añade un control Timer y un ListView en el formulario.

En Timer1_Timer() se llama a la rutina CheckRASConnections… cuando inicias una conexión RAS la función detecta la nueva conexión y comienza a calcular el tiempo de la conexión. Cuando la conexión termina el contador de tiempo se para mostrando el tiempo total conectado.

Usa la función CheckConnections para saber cuando comienza una nueva conexión o cuando termina… llama a esta función en la rutina del Timer

Este código va en el Formulario.

Option Explicit
Private Sub Form_Load()
    Timer1.Interval = 1000
End Sub
Sub Timer1_Timer()
    Dim x As Integer

    x = CheckConnections
    If x > 0 Then
        MsgBox x & " New Connection Started"
    ElseIf x < 0 Then
        MsgBox Abs(x) & " Connection Terminated"
    End If
End Sub

Y este otro en un módulo.

Option Explicit
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" _
                            (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long

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 ERROR_SUCCESS = 0

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 Function ByteToString(ByteArray() As Byte) As String
    ' Convierte el array de Byte devuelta por el API en un String
    Dim i As Integer

    ByteToString = ""
    i = 0
    Do While ByteArray(i)  0
        ByteToString = ByteToString & Chr(ByteArray(i))
        i = i + 1
    Loop
End Function
Private Function toTime(ByVal x As Single) As String
    ' Convierte un Single en String formato Horario
    toTime = Format(x Mod 60, "00")
    toTime = ":" & toTime
    x = x  60
    toTime = Format(x Mod 60, "00") & toTime
    toTime = ":" & toTime
    x = x  60
    toTime = x & toTime
End Function
Sub CheckRASConnections()
    ' Comprueba las conexiones RAS
    Dim i As Long
    Dim RasConn(255) As RasConn
    Dim structSize As Long
    Dim ConnectionsCount As Long
    Dim ret As Long
    Static LastTime As Single
    Dim ElapsedTime As Single

    If LastTime = 0 Then LastTime = Timer
    'Fills the RasConn structure with the data of all the opened RAS connections
    RasConn(0).dwSize = RAS_RASCONNSIZE
    structSize = RAS_MAXENTRYNAME * RasConn(0).dwSize
    ret = RasEnumConnections(RasConn(0), structSize, ConnectionsCount)
    ElapsedTime = Timer - LastTime
    If ElapsedTime < 0 Then ElapsedTime = 0
    'Each call to the Sub recalculate the elapsed time for all the active or new RAS connections
    If ret = ERROR_SUCCESS Then
        For i = 0 To ConnectionsCount - 1
            On Error GoTo NewConnection
            'Update an existing list item connection
            Form1.ListView1.ListItems("K" & RasConn(i).hRasConn).Tag = _
                Form1.ListView1.ListItems("K" & RasConn(i).hRasConn).Tag + ElapsedTime
            Form1.ListView1.ListItems("K" & RasConn(i).hRasConn).Text = _
                ByteToString(RasConn(i).szEntryName) & "-" & _
                toTime(Form1.ListView1.ListItems("K" & RasConn(i).hRasConn).Tag)
            GoTo NextConnection
NewConnection:
            'Create a new list item connection
            Form1.ListView1.ListItems.Add , "K" & RasConn(i).hRasConn, _
                ByteToString(RasConn(i).szEntryName)
            Form1.ListView1.ListItems("K" & RasConn(i).hRasConn).Tag = 0
NextConnection:
        Next
    End If
    LastTime = Timer
End Sub
Function CheckConnections() As Integer
    'Tells you if a Connection as been started or terminated
    'Returns the number of new connections, if the number is greater than
    'zero it indicates the number of new connections started, if the number
    'is negatice it indicates the number of connections terminated, zero if
    'the number of RAS connections is the same
    Static ConnCount As Integer
    Dim RasConn(255) As RasConn
    Dim structSize As Long
    Dim ConnectionsCount As Long
    Dim ret As Long

    'Fills the RasConn structure with the data of all the opened RAS connections
    RasConn(0).dwSize = RAS_RASCONNSIZE
    structSize = RAS_MAXENTRYNAME * RasConn(0).dwSize
    ret = RasEnumConnections(RasConn(0), structSize, ConnectionsCount)
    CheckConnections = ConnectionsCount - ConnCount
    ConnCount = ConnectionsCount
End Function

Enviado por Andrea Tincani

Capturar el Escritorio actual de Windows

Para probar, incluye el siguiente código en un proyecto nuevo.

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
        ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Sub Form_Load()
    Caption = "Haz click sobre la ventana"
End Sub
Private Sub Form_Click()
    Dim DhWnd As Long, DhDC As Long, Img As RECT
    DhWnd = GetDesktopWindow
    DhDC = GetDC(DhWnd)
    GetWindowRect DhWnd, Img
    BitBlt Me.hDC, 0&, 0&, Me.Width, Me.Height, DhDC, 0&, 0&, &HCC0020
    ReleaseDC DhWnd, DhDC
End Sub