Spoolerinhalt von Standartdrucker löschen

[wetlook]

Halli hallo,
ich habe schon ewig gegoogled aber noch nix gefunden, deshalb hoffe ich auf eure Hilfe:
Wie kann ich alle Druckaufträge im Spooler vom Windows-Standartdrucker löschen?
Ich bräuchte einen Button-->klick-->Druckaufträge weg...
Kann mir da jemand helfen?

[database]

hi,

hilft dir das vielleicht weiter?

http://www.vbarchiv.net/tipps/details.php?id=136

p.s. unter dem Code im Beispiel bitte auch den Hinweis beachten!

[wetlook]

Hallo,
ja das hatte ich gefunden, aber mir schmiert der Rechner ab bzw. Access bleibt hängen...
Ich hab es wie folgt eingebaut:
Formular mit 1 Button.
Im Vba-Kopfbereich dieses:

Code [Auswählen] Erweitern


Private Declare Function SetPrinter Lib "winspool.drv" _
  Alias "SetPrinterA" ( _
  ByVal hPrinter As Long, _
  ByVal Level As Long, _
  pPrinter As Any, _
  ByVal Command As Long) As Long

Private Declare Function OpenPrinter Lib "winspool.drv" _
  Alias "OpenPrinterA" ( _
  ByVal pPrinterName As String, _
  phPrinter As Long, _
  pDefault As Any) As Long

Private Declare Function ClosePrinter Lib "winspool.drv" ( _
  ByVal hPrinter As Long) As Long

Private Const PRINTER_CONTROL_PURGE = 3

Private Type PRINTER_DEFAULTS
  pDatatype As String
  pDevMode As Long
  DesiredAccess As Long
End Type

Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const PRINTER_ATTRIBUTE_DEFAULT = &H4
Private Const PRINTER_ACCESS_ADMINISTER = &H4
Private Const PRINTER_ACCESS_USE = &H8
Private Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
  PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)


Über den Button dann eine Schleife für 25 Sekunden laufen lassen (i ist ein Wert aus einem anderen System, funzt aber-hier nur i=1 zum Test damit die i-Schleife immer weiter läuft)

Code [Auswählen] Erweitern


Private Sub Befehl1_Click()

Do While i > 0
i = 1
For x = 1 To 25
DoEvents
   sleep 1000

Next x
If x > 29 Then GoTo Codestop Else GoTo loopnext

loopnext:
Loop

Codestop:
Call DeleteDocsFromPrinterQueue
MsgBox "stop"

End Sub


Und dann noch das Modul mit dem Inhalt

Code [Auswählen] Erweitern


Public Sub DeleteDocsFromPrinterQueue(Optional _
  ByVal prnName As String)

  Dim Result As Long
  Dim hPrinter As Variant
  Dim udtPrinter As PRINTER_DEFAULTS

  If IsMissing(prnName) Or prnName = "" Then _
    prnName = Printer.DeviceName

  udtPrinter.DesiredAccess = PRINTER_ALL_ACCESS

  Result = OpenPrinter(prnName, hPrinter, udtPrinter)
  If hPrinter <> 0 Then
    Result = SetPrinter(hPrinter, 0, vbNull, _
      PRINTER_CONTROL_PURGE)
    If Result = 0 Then RaiseLastWin32Error
  End If
  Result = ClosePrinter(hPrinter)


Wenn ich das ausführe bleibt das System hängen... Aber warum?

[daolix]

Code [Auswählen] Erweitern

Private Sub Befehl1_Click()

Do While i > 0
i = 1
For x = 1 To 25
DoEvents
   sleep 1000

Next x
If x > 29 Then GoTo Codestop Else GoTo loopnext

loopnext:
Loop

Codestop:
Call DeleteDocsFromPrinterQueue
MsgBox "stop"

End Sub
Ich weis jetzt nicht was du mit dieser Funktion erreichen willst.
i ist 0, also wird die do/loop-schleife nicht gestartet (do while i>0), ausser i ist irgendwo global definert.
Zum anderen, wenn i >= 1 ist wird die Do/loop gestartet wird aber nie beendet weil For x = 1 To 25 den x-Wert immer zurücksetzt und der Wert 29 nie erreicht wird.
müsste also lauten: If x > 25 Then exit Do
Die Funktion DeleteDocsFromPrinterQueue selbst schein zu funktionieren. Was sich bei dir jetzt aufhängt kann ich nicht reproduziren.

[wetlook]

Hallo,
bei der Schleife scheint mir ein Fehler beim kopieren unterlaufen zu sein. Da steht bei mir schon
>25 aber muss es mit exit do beendet werden oder geht auch mein goto?

Beim Spooler-löschen geht er ins debug und markiert mir mit Benutzerdefinierter Typ nicht definiert den Code

Code [Auswählen] Erweitern


udtPrinter As PRINTER_DEFAULTS


Greift der Code denn automatisch auf den Windows Standartdrucker zu? Wenn nicht, wie bekomme ich das hin?
Bin hiermit leicht überfordert....

[wetlook]

komischerweise markiert er manchmal auch dieses:

Code [Auswählen] Erweitern


RaiseLastWin32Error

Es scheint fast abwechselnd zu sein... oder habe ich etwas vergessen?

[wetlook]

AHHH ok,
hab das fehlende Modul ergänzt und Z A C K  alles geht..
Für alle die diese Funktion nutzen möchten:
Einfach folgenden Code in ein Modul setzten und schon geht es:

Code [Auswählen] Erweitern


Option Explicit

' Benötigte API-Deklarationen
Private Declare Function FormatMessage Lib "kernel32" _
  Alias "FormatMessageA" ( _
  ByVal dwFlags As Long, _
  lpSource As Any, _
  ByVal dwMessageId As Long, _
  ByVal dwLanguageId As Long, _
  lpBuffer As Long, _
  ByVal nSize As Long, _
  Arguments As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  Destination As Any, _
  Source As Any, _
  ByVal Length As Long)

Private Declare Function LocalFree Lib "kernel32" ( _
  ByVal hMem As Long) As Long
' ----------------------------------------------------
' Letzten Fehler einer WinAPI Funktion im Klartext
' ermitteln
' ----------------------------------------------------
Public Sub RaiseLastWin32Error()
  Const UNKNOW_WIN32API_ERROR = _
    "Ein unbekannter Win32 API Fehler ist aufgetreten."
  Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
  Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
  Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
  Const LANG_NEUTRAL = &H0
  Const ERROR_SUCCESS = 0&

  Dim Buffer As Long
  Dim Length As Long
  Dim ErrorMsg As String
  Dim LastError As Long

  ' Letzten Win32 API Fehler ermitteln
  LastError = Err.LastDllError

  ' Win32 API Fehler von Windows in einen Text ausgeben
  Length = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER Or _
    FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
    0&, LastError, LANG_NEUTRAL, Buffer, 0, 0)

  ' Prüfen ob letzter Fehler wirklich ein Fehler war
  ' und prüfen ob FormatMessage einen Text bereit
  ' gestellt hat
  If (LastError <> ERROR_SUCCESS) And (Length <> 0) Then
    ErrorMsg = String$(Length, vbNullChar)
    Call CopyMemory(ByVal ErrorMsg, ByVal Buffer, Length)
    Call LocalFree(Buffer)
  Else
    ErrorMsg = UNKNOW_WIN32API_ERROR
  End If

  ' Fehlermeldung ausgeben
  Call Err.Raise(Number:=vbObjectError + LastError, _
    Source:="RaiseLastWin32Error", Description:=ErrorMsg)
End Sub