Option Explicit

Function ReadLargeFile(ByVal Filename As String) As Long
        Dim lDataChunkSize&
        Dim lNumberOfChunks&
        Dim hFile&, lFileLen&
        Dim lMemOffset&, lReadLen&
        Dim hMem&, i&, r&

  ' Abre el archivo para lectura.
  '
  hFile = CreateFile(Filename, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                     0&, OPEN_EXISTING, 0&, 0&)
  
  If hFile = INVALID_HANDLE_VALUE Then Exit Function
  
  ' Se obtiene el tamaño del archivo.
  '
  lFileLen = GetFileSize(hFile, 0&)
  
  lDataChunkSize = 1024& * 1024&  ' Se leerá de a trozos de 1 MB
  
  ' Si calcula en cuántas veces se leerá el archivo.
  '
  lNumberOfChunks = lFileLen \ lDataChunkSize
    
  If lNumberOfChunks = 0 Then
    lNumberOfChunks = 1 ' El archivo en menor a 1 MB.
  Else
    ' Calcula la longitud de los datos de la última
    ' sección del archivo, que seguramente es menor
    ' a 1 Megabyte.
    '
    If (lFileLen Mod lDataChunkSize) > 0 Then lNumberOfChunks = lNumberOfChunks + 1
  End If
  
  ' Asigna memoria para leer el archivo.
  '
  hMem = VirtualAlloc(0&, lFileLen, MEM_COMMIT, PAGE_READWRITE)
  
  If hMem = 0 Then GoTo FailRead
  
  For i = 1 To lNumberOfChunks
    ' Se verifica si es la última sección del archivo o no.
    '
    If i < lNumberOfChunks Then
      lReadLen = lDataChunkSize
    Else
      lReadLen = lFileLen Mod lDataChunkSize
    End If
    
    ' Lee el trozo del archivo a la memoria.
    '
    r = ReadFile(hFile, ByVal hMem + lMemOffset, lReadLen, 0, ByVal 0&)
    
    If r = 0 Then GoTo FailRead
    
    ' Pasa al siguiente trozo de datos.
    '
    lMemOffset = lMemOffset + lReadLen

    DoEvents
  Next

FailRead:
  If Err.LastDllError <> ERROR_SUCCESS Then
    ' Libera la memoria si no se pudo leer el archivo.
    '
    Debug.Print GetSysErr(Err.LastDllError)
    r = VirtualFree(hMem, 0, MEM_RELEASE)
  Else
    ' Devuelve el puntero al inicio del archivo en memoria.
    '
    ReadLargeFile = hMem
  End If
  
  ' Cierra el archivo.
  '
  r = CloseHandle(hFile)

End Function

Function GetSysErr(ByVal ErrNumber As Long) As String
        Dim sBuffer$, lLen&

  sBuffer = String$(1024, 0)
  
  lLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrNumber, 0&, ByVal sBuffer, 1024, ByVal 0&)
  
  If lLen Then
    sBuffer = Left$(sBuffer, lLen)
  End If
  
  GetSysErr = sBuffer
End Function

Option Explicit

Public Const PRINTER_STATUS_BUSY = &H200
Public Const PRINTER_STATUS_DOOR_OPEN = &H400000
Public Const PRINTER_STATUS_ERROR = &H2
Public Const PRINTER_STATUS_INITIALIZING = &H8000
Public Const PRINTER_STATUS_IO_ACTIVE = &H100
Public Const PRINTER_STATUS_MANUAL_FEED = &H20
Public Const PRINTER_STATUS_NO_TONER = &H40000
Public Const PRINTER_STATUS_NOT_AVAILABLE = &H1000
Public Const PRINTER_STATUS_OFFLINE = &H80
Public Const PRINTER_STATUS_OUT_OF_MEMORY = &H200000
Public Const PRINTER_STATUS_OUTPUT_BIN_FULL = &H800
Public Const PRINTER_STATUS_PAGE_PUNT = &H80000
Public Const PRINTER_STATUS_PAPER_JAM = &H8
Public Const PRINTER_STATUS_PAPER_OUT = &H10
Public Const PRINTER_STATUS_PAPER_PROBLEM = &H40
Public Const PRINTER_STATUS_PAUSED = &H1
Public Const PRINTER_STATUS_PENDING_DELETION = &H4
Public Const PRINTER_STATUS_PRINTING = &H400
Public Const PRINTER_STATUS_PROCESSING = &H4000
Public Const PRINTER_STATUS_TONER_LOW = &H20000
Public Const PRINTER_STATUS_USER_INTERVENTION = &H100000
Public Const PRINTER_STATUS_WAITING = &H2000
Public Const PRINTER_STATUS_WARMING_UP = &H10000

Const ERROR_INSUFFICIENT_BUFFER = 122

Const MEM_COMMIT = &H1000&
Const PAGE_READWRITE = 4
Const MEM_RELEASE = &H8000

Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32

Private Type DEVMODE
  dmDeviceName(1 To CCHDEVICENAME) As Byte
  dmSpecVersion       As Integer
  dmDriverVersion     As Integer
  dmSize              As Integer
  dmDriverExtra       As Integer
  dmFields            As Long
  dmOrientation       As Integer
  dmPaperSize         As Integer
  dmPaperLength       As Integer
  dmPaperWidth        As Integer
  dmScale             As Integer
  dmCopies            As Integer
  dmDefaultSource     As Integer
  dmPrintQuality      As Integer
  dmColor             As Integer
  dmDuplex            As Integer
  dmYResolution       As Integer
  dmTTOption          As Integer
  dmCollate           As Integer
  dmFormName(1 To CCHFORMNAME) As Byte
  dmUnusedPadding     As Integer
  dmBitsPerPel        As Long
  dmPelsWidth         As Long
  dmPelsHeight        As Long
  dmDisplayFlags      As Long
  dmDisplayFrequency  As Long
End Type

Private Type ACL
  AclRevision As Byte
  Sbz1        As Byte
  AclSize     As Integer
  AceCount    As Integer
  Sbz2        As Integer
End Type

Private Type SECURITY_DESCRIPTOR
  Revision  As Byte
  Sbz1      As Byte
  Control   As Long
  Owner     As Long
  Group     As Long
  Sacl      As ACL
  Dacl      As ACL
End Type

Private Type PRINTER_INFO_2
  pServerName         As Long ' lpstr
  pPrinterName        As Long ' lpstr
  pShareName          As Long ' lpstr
  pPortName           As Long ' lpstr
  pDriverName         As Long ' lpstr
  pComment            As Long ' lpstr
  pLocation           As Long ' lpstr
  pDevMode            As DEVMODE
  pSepFile            As Long ' lpstr
  pPrintProcessor     As Long ' lpstr
  pDatatype           As Long ' lpstr
  pParameters         As Long ' lpstr
  pSecurityDescriptor As SECURITY_DESCRIPTOR
  Attributes          As Long
  Priority            As Long
  DefaultPriority     As Long
  StartTime           As Long
  UntilTime           As Long
  Status              As Long
  cJobs               As Long
  AveragePPM          As Long
End Type

Type PrinterInfo
  ServerName      As String ' Nombre del servidor donde se encuentra (si es local sería localhost).
  PrinterName     As String ' Nombre de la impresora.
  ShareName       As String ' Nombre del recurso compartido.
  PortName        As String ' Nombre del puerto (LPT1, LPT2, etc)
  DriverName      As String ' Nombre del controlador de impresora.
  Comment         As String ' Comentarios.
  Location        As String ' Ubicación.
  PrintProcessor  As String ' Nombre del procesador de la impresora.
  Status          As Long   ' Estado de la impresora.
  Jobs            As Long   ' Cantidad de trabajos en la cola.
  AveragePPM      As Long   ' Páginas por minuto que imprime.
End Type

Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Public Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Public Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long

Public Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Public Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long
Public Declare Function lstrlenptr Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long

Public Declare Function GetCurrentProcess Lib "kernel32" () As Long

Function GetPrinterInfo(ByVal DeviceName As String) As PrinterInfo
        Dim lpPrinterInfo As PRINTER_INFO_2
        Dim lBytesNeeded&, hPrinter&
        Dim hMem&, r&


  ' Abre la impresora y devuelve un controlador de impresora (hPrinter).
  '
  r = OpenPrinter(DeviceName, hPrinter, 0&)

  If r = 0 Then
    Debug.Print "No se pudo abrir la impresora especificada"
    
    Exit Function
  End If
  
  ' Primero obtiene el tamaño de los datos para
  ' la impresora especificada.
  '
  r = GetPrinter(hPrinter, 2, 0&, 0&, lBytesNeeded)
  
  If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then
    ' Asigna memoria para utilizarla como buffer en
    ' la llamada a la función GetPrinter.
    '
    hMem = VirtualAlloc(0&, lBytesNeeded, MEM_COMMIT, PAGE_READWRITE)
    
    ' Ahora sí obtiene la información de la impresora especificada.
    '
    r = GetPrinter(hPrinter, 2, ByVal hMem, lBytesNeeded, lBytesNeeded)
    
    If r = 0 Then GoTo GetInfoFail
    
    ' Copia los datos a la variable lpPrinterInfo.
    '
    r = ReadProcessMemory(GetCurrentProcess, hMem, lpPrinterInfo, LenB(lpPrinterInfo))
    r = VirtualFree(hMem, 0&, MEM_RELEASE)  ' Libera la memoria.
  Else
GetInfoFail:
    Debug.Print "No se puede obtener información de la impresora."
    
    GoTo PrinterFault
  End If
  
  With GetPrinterInfo
    .AveragePPM = lpPrinterInfo.AveragePPM
    .Comment = PtrToStrA(lpPrinterInfo.pComment)
    .DriverName = PtrToStrA(lpPrinterInfo.pDriverName)
    .Jobs = lpPrinterInfo.cJobs
    .Location = PtrToStrA(lpPrinterInfo.pLocation)
    .PortName = PtrToStrA(lpPrinterInfo.pPortName)
    .PrinterName = PtrToStrA(lpPrinterInfo.pPrinterName)
    .PrintProcessor = PtrToStrA(lpPrinterInfo.pPrintProcessor)
    .ServerName = PtrToStrA(lpPrinterInfo.pServerName)
    .ShareName = PtrToStrA(lpPrinterInfo.pShareName)
    .Status = lpPrinterInfo.Status
  End With
  
PrinterFault:
  ' Cierra la impresora.
  '
  r = ClosePrinter(hPrinter)

End Function

Function PtrToStrA(ByVal lpAnsiStr As Long) As String
  ' Esta función convierte un puntero de cadena ANSI
  ' en una variable String.
  '
      Dim sData$
      Dim lLen&

  lLen = lstrlenptr(lpAnsiStr)
  sData = String$(lLen, 0)
  
  If ReadProcessMemory(GetCurrentProcess(), lpAnsiStr, ByVal sData, lLen) Then
    PtrToStrA = sData
  End If
End Function

Sub EnumPrinterInfo()
      Dim lpInfo As PrinterInfo
      Dim csPrinter

  For Each csPrinter In Printers
    lpInfo = GetPrinterInfo(csPrinter.DeviceName)
    
    Debug.Print "La impresora " & lpInfo.PrinterName & " tiene " _
                & lpInfo.Jobs & " trabajos en cola."

  Next
End Sub

Public bTerminateApp As Boolean

Sub Main()
  Call SetTimer(0&, 0&, 1000&, AddressOf Timer1)
  Call SetTimer(0&, 0&, 2000&, AddressOf Timer2)
  Call SetTimer(0&, 0&, 3000&, AddressOf Timer3)

  Do While Not bTerminateApp
    DoEvents
  Loop
End Sub

Sub Timer1(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Integer, ByVal dwTime As Long)
  Debug.Print "El idEvent de Timer1 es " & idEvent

  ' Elimina el temporizador.
  '
  Call KillTimer(0&, idEvent)
End Sub

Sub Timer2(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Integer, ByVal dwTime As Long)
  Debug.Print "El idEvent de Timer1 es " & idEvent

  ' Elimina el temporizador.
  '
  Call KillTimer(0&, idEvent)
End Sub

Sub Timer3(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Integer, ByVal dwTime As Long)
  Debug.Print "El idEvent de Timer1 es " & idEvent

  ' Elimina el temporizador.
  '
  Call KillTimer(0&, idEvent)

  ' Cuando termina el tercer temporizador, establece
  ' la variable global a True y el procedimiento Sub Main
  ' sale del bucle de espera.
  '
  bTerminateApp = True
End Sub

Call Kill("C:\*.jpg")

Sub Main()
  Call SetTimer(0&, 0&, 1000&, AddressOf Timer1)
  Call SetTimer(0&, 0&, 2000&, AddressOf Timer2)
  Call SetTimer(0&, 0&, 3000&, AddressOf Timer3)
End Sub

Sub Timer1(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Integer, ByVal dwTime As Long)
  Debug.Print "El idEvent de Timer1 es " & idEvent

  ' Elimina el temporizador.
  '
  Call KillTimer(0&, idEvent)
End Sub

Sub Timer2(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Integer, ByVal dwTime As Long)
  Debug.Print "El idEvent de Timer1 es " & idEvent

  ' Elimina el temporizador.
  '
  Call KillTimer(0&, idEvent)
End Sub

Sub Timer3(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Integer, ByVal dwTime As Long)
  Debug.Print "El idEvent de Timer1 es " & idEvent

  ' Elimina el temporizador.
  '
  Call KillTimer(0&, idEvent)
End Sub