VBA - XPS Viewer ansteuern - MS-Office-Forum

Venom · 02.03.2011, 14:30

Hallo
ich würde gern den XPS Viewer von Windows ansteuern, etwas darüber Drucken und die gedruckte Datei in einem bestimmten Ort über Variablen mit einem Variablen Namen ablegen.

Geht das?

Der Makrorecorder gab folgendes aus:

Code:

    Application.ActivePrinter = "Microsoft XPS Document Writer auf Ne02:"
    ExecuteExcel4Macro _
        "PRINT(1,,,1,,,,,,,,2,""Microsoft XPS Document Writer auf Ne02:"",,TRUE,,FALSE)"

Um Ehrlich zu sein hilft mir das bei der Pfad und Namensgebung nicht so recht weiter

Danke

josef e · 02.03.2011, 23:05

Hallo ?,

eine Möglichkeit.

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long

Const PRINTER_ENUM_LOCAL = &H2

Private Type PRINTER_INFO_1
  flags As Long
  pDescription As String
  pName As String
  pComment As String
End Type

Sub printXPS()
  Dim strFileXPS As String, strPrinterXPS As String

  strFileXPS = Application.GetSaveAsFilename("New.xps", "XPS Files (*.xps), *.xps")

  If strFileXPS = CStr(False) Then Exit Sub

  strPrinterXPS = findPrinter("xps")

  If strPrinterXPS <> "" Then
    ActiveSheet.PrintOut ActivePrinter:=strPrinterXPS, PrToFilename:=strFileXPS
  Else
    MsgBox "Kein XPS-Drucker gefunden!"
  End If

End Sub

Private Function findPrinter(NamePart As String) As String
  'Original by
  'KPD-Team 1999
  'URL: http://www.allapi.net/
  'E-Mail: KPDTeam@Allapi.net
  Dim longbuffer() As Long ' resizable array receives information from the function
  Dim printinfo() As PRINTER_INFO_1 ' values inside longbuffer() will be put into here
  Dim numbytes As Long ' size in bytes of longbuffer()
  Dim numneeded As Long ' receives number of bytes necessary if longbuffer() is too small
  Dim numprinters As Long ' receives number of printers found
  Dim c As Integer, retval As Long ' counter variable & return value

  ' Get information about the local printers
  numbytes = 3076 ' should be sufficiently big, but it may not be
  Redim longbuffer(0 To numbytes / 4) As Long ' resize array -- note how 1 Long = 4 bytes
  retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters)
  If retval = 0 Then ' try enlarging longbuffer() to receive all necessary information
    numbytes = numneeded
    Redim longbuffer(0 To numbytes / 4) As Long ' make it large enough
    retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters)
    If retval = 0 Then Exit Function
  End If
  ' Convert longbuffer() data into printinfo()
  If numprinters <> 0 Then Redim printinfo(0 To numprinters - 1) As PRINTER_INFO_1 ' room for each printer
  For c = 0 To numprinters - 1 ' loop, putting each set of information into each element
    ' longbuffer(4 * c) = .flags, longbuffer(4 * c + 1) = .pDescription, etc.
    ' For each string, the string is first buffered to provide enough room, and then the string is copied.
    printinfo(c).flags = longbuffer(4 * c)
    printinfo(c).pDescription = Space(lstrlen(longbuffer(4 * c + 1)))
    retval = lstrcpy(printinfo(c).pDescription, longbuffer(4 * c + 1))
    printinfo(c).pName = Space(lstrlen(longbuffer(4 * c + 2)))
    retval = lstrcpy(printinfo(c).pName, longbuffer(4 * c + 2))
    printinfo(c).pComment = Space(lstrlen(longbuffer(4 * c + 3)))
    retval = lstrcpy(printinfo(c).pComment, longbuffer(4 * c + 3))
  Next c
  ' Display name of each printer
  For c = 0 To numprinters - 1
    If LCase(printinfo(c).pName) Like "*" & LCase(NamePart) & "*" Then findPrinter = printinfo(c).pName
  Next c
End Function

Gruß Sepp

02.03.2011, 14:30	#1
Venom MOF Profi Registrierung: 02.10.2003 Ort: Hessen, Kassel Beiträge: 977 Karma: Modifikator: 21	VBA - XPS Viewer ansteuern Hallo ich würde gern den XPS Viewer von Windows ansteuern, etwas darüber Drucken und die gedruckte Datei in einem bestimmten Ort über Variablen mit einem Variablen Namen ablegen. Geht das? Der Makrorecorder gab folgendes aus: Code: Application.ActivePrinter = "Microsoft XPS Document Writer auf Ne02:" ExecuteExcel4Macro _ "PRINT(1,,,1,,,,,,,,2,""Microsoft XPS Document Writer auf Ne02:"",,TRUE,,FALSE)" Um Ehrlich zu sein hilft mir das bei der Pfad und Namensgebung nicht so recht weiter Danke __________________ Danke das Ihr eure Zeit für mich opfert!

Themen-Optionen
Druckbare Version zeigen Diese Seite per E-Mail verschicken
Ansicht
Linear-Darstellung Zur Hybrid-Darstellung wechseln Zur Baum-Darstellung wechseln

02.03.2011, 23:05	#2
josef e MOF Meister Registrierung: 13.05.2009 Beiträge: 3.501 Karma: Modifikator: 21	Hallo ?, eine Möglichkeit. ' ******************************************************************** ' Modul: Modul3 Typ: Allgemeines Modul ' ****************************************************************** Option Explicit Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpString As Long) As Long Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long Const PRINTER_ENUM_LOCAL = &H2 Private Type PRINTER_INFO_1 flags As Long pDescription As String pName As String pComment As String End Type Sub printXPS()** Dim strFileXPS As String, strPrinterXPS As String strFileXPS = Application.GetSaveAsFilename("New.xps", "XPS Files (.xps), .xps") If strFileXPS = CStr(False) Then Exit Sub strPrinterXPS = findPrinter("xps") If strPrinterXPS <> "" Then ActiveSheet.PrintOut ActivePrinter:=strPrinterXPS, PrToFilename:=strFileXPS Else MsgBox "Kein XPS-Drucker gefunden!" End If End Sub Private Function findPrinter(NamePart As String) As String 'Original by 'KPD-Team 1999 'URL: http://www.allapi.net/ 'E-Mail: KPDTeam@Allapi.net Dim longbuffer() As Long ' resizable array receives information from the function Dim printinfo() As PRINTER_INFO_1 ' values inside longbuffer() will be put into here Dim numbytes As Long ' size in bytes of longbuffer() Dim numneeded As Long ' receives number of bytes necessary if longbuffer() is too small Dim numprinters As Long ' receives number of printers found Dim c As Integer, retval As Long ' counter variable & return value ' Get information about the local printers numbytes = 3076 ' should be sufficiently big, but it may not be Redim longbuffer(0 To numbytes / 4) As Long ' resize array -- note how 1 Long = 4 bytes retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters) If retval = 0 Then ' try enlarging longbuffer() to receive all necessary information numbytes = numneeded Redim longbuffer(0 To numbytes / 4) As Long ' make it large enough retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer(0), numbytes, numneeded, numprinters) If retval = 0 Then Exit Function End If ' Convert longbuffer() data into printinfo() If numprinters <> 0 Then Redim printinfo(0 To numprinters - 1) As PRINTER_INFO_1 ' room for each printer For c = 0 To numprinters - 1 ' loop, putting each set of information into each element ' longbuffer(4 * c) = .flags, longbuffer(4 * c + 1) = .pDescription, etc. ' For each string, the string is first buffered to provide enough room, and then the string is copied. printinfo(c).flags = longbuffer(4 * c) printinfo(c).pDescription = Space(lstrlen(longbuffer(4 * c + 1))) retval = lstrcpy(printinfo(c).pDescription, longbuffer(4 * c + 1)) printinfo(c).pName = Space(lstrlen(longbuffer(4 * c + 2))) retval = lstrcpy(printinfo(c).pName, longbuffer(4 * c + 2)) printinfo(c).pComment = Space(lstrlen(longbuffer(4 * c + 3))) retval = lstrcpy(printinfo(c).pComment, longbuffer(4 * c + 3)) Next c ' Display name of each printer For c = 0 To numprinters - 1 If LCase(printinfo(c).pName) Like "" & LCase(NamePart) & "" Then findPrinter = printinfo(c).pName Next c End Function Gruß Sepp

Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)