Excel mit VBA in PDF speichern, geänderter Bezug, was dann?
Sepp, Salzburg
wenn ich mit VBA ein PDF Format generiere sieht der Code wie folgt aus:
Application.ActivePrinter = "Adobe PDF auf Ne06:"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"Adobe PDF auf Ne06:", Collate:=True
Mein Problem:
Wird der PC oder der Drucker gewechselt ändert sich meistens der Bezug,
z.B von Ne03 auf Ne04, d.h. das Makro funktioniert nicht mehr und muss
angepasst werden.
Gibt es eine Möglichkeit den Code so zu erstellen, dass der Bezug immer
richtig ist?
Ich arbeite mit Excel 2003, SP3, Windows XP
Im Voraus besten Dank für Eure Mühe und schöne Grüße aus Salzburg
--
Sepp, Salzburg
Andreas Killer
> Application.ActivePrinter = "Adobe PDF auf Ne06:"
> ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
> "Adobe PDF auf Ne06:", Collate:=True
>
> Wird der PC oder der Drucker gewechselt ändert sich meistens der Bezug,
> z.B von Ne03 auf Ne04, d.h. das Makro funktioniert nicht mehr und muss
> angepasst werden.
>
> Gibt es eine Möglichkeit den Code so zu erstellen, dass der Bezug immer
> richtig ist?
Es ist möglich alle Drucker des System's zu ermitteln und aus diesen
könnte man den geeigneten auswählen, z.B. wenn der Name PDF enthält.
Kopier mal den angehängten Code in ein Modul und starte die "Sub
Test". Wenn Sie "Adobe PDF auf Ne06:" ausgibt sollte es auf anderen
System auch gehen.
Andreas.
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
Private Const PRINTER_ENUM_LOCAL = &H2
Private Type PRINTER_INFO_1
flags As Long
pDescription As String
pName As String
pComment As String
End Type
Public Function GetPDFPrinterName() As String
Dim longbuffer() As Long
Dim printinfo() As PRINTER_INFO_1
Dim numbytes As Long, numneeded As Long, numprinters As Long
Dim c As Integer, retval As Long
numbytes = 3076 ' should be sufficiently big, but it may _
not be
ReDim longbuffer(0 To numbytes / 4) As Long
retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, longbuffer( _
0), numbytes, numneeded, numprinters)
' try enlarging longbuffer() to receive all necessary _
information
If retval = 0 Then
numbytes = numneeded
' make it large enough
ReDim longbuffer(0 To numbytes / 4) As Long
retval = EnumPrinters(PRINTER_ENUM_LOCAL, "", 1, _
longbuffer(0), numbytes, numneeded, numprinters)
If retval = 0 Then
' failed again!
Exit Function
End If
End If
' Convert longbuffer() data into printinfo()
If numprinters <> 0 Then
' room for each printer
ReDim printinfo(0 To numprinters - 1) As PRINTER_INFO_1
End If
For c = 0 To numprinters - 1
' 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
'Debug.Print "Name of printer"; c + 1; " is: "; printinfo( _
c).pName
If InStr(1, printinfo(c).pName, "PDF", vbTextCompare) > 0 _
Then
GetPDFPrinterName = printinfo(c).pName
Exit Function
End If
Next c
End Function
Sub Test()
MsgBox GetPDFPrinterName
End Sub
Michael v. Fondern
>
> Gibt es eine Möglichkeit den Code so zu erstellen, dass der Bezug immer
> richtig ist?
>
Du könntest zunächst die Liste der verfügbaren Drucker ermitteln, dafür
nimmst du die Funtion hier:
http://word.mvps.org/FAQs/MacrosVBA/AvailablePrinters.htm
Dann suchst du dir anschließend mit einer Schleife denjenigen heraus,
dessen Name mit "Adobe PDF" anfängt.
Grüße
- Michael -
Michael Schwimmer
Am Fri, 12 Feb 2010 09:49:01 -0800 schrieb Sepp, Salzburg:
> Wird der PC oder der Drucker gewechselt �ndert sich meistens der Bezug,
> z.B von Ne03 auf Ne04, d.h. das Makro funktioniert nicht mehr und muss
> angepasst werden.
> Gibt es eine M�glichkeit den Code so zu erstellen, dass der Bezug immer
> richtig ist?
kannst ja mal probieren, ob folgendes funktioniert:
Sub test1()
Dim varPrinter As Variant
For Each varPrinter In Split(GetAllPrinter(), vbCrLf)
If InStr(1, varPrinter, "PDF") > 0 Then
MsgBox varPrinter, vbInformation, "Mach was mit mir"
Exit For
End If
Next
End Sub
Public Function GetAllPrinter( _
Optional strOn As String = "auf") As String
Dim objWMIService As Object
Dim objQuery As Object
Dim objItem As Object
Dim strComputer As String
Dim strPort As String
Dim strPrinter As String
Dim objShell As Object
' Position des Schl�ssels in der Registry f�r die Portnummer
Const Ports As String = _
"HKEY_CURRENT_USER\Software\Microsoft\Windows NT\" & _
"CurrentVersion\PrinterPorts\"
On Error Resume Next
' Objekt zum einfachen Zugriff auf die Registry erzeugen
If strOn <> "" Then Set objShell = CreateObject("WScript.Shell")
' Rechnername f�r WMI
strComputer = "." ' Lokal
' WMI-Objekt erzeugen
Set objWMIService = GetObject("winmgmts:\\" & _
strComputer & "\root\cimv2")
' WQL (WMI Query Language ) Abfrage starten
Set objQuery = objWMIService.ExecQuery( _
"Select * from Win32_PrinterConfiguration")
' Alle zur�ckgelieferten Elemente durchlaufen
For Each objItem In objQuery
strPrinter = objItem.name
GetAllPrinter = GetAllPrinter & strPrinter
If strOn <> "" Then
' Portname ermitteln
strPort = Split(objShell.RegRead(Ports & strPrinter), ",")(1)
' und mitsamt Bindewort (hier 'auf') anh�ngen
GetAllPrinter = GetAllPrinter & " " & strOn & " " & strPort
End If
' Zeilenumbruch anh�ngen
GetAllPrinter = GetAllPrinter & vbCrLf
Next
' Um den letzten Zeilenumbruch k�rzen
GetAllPrinter = Left(GetAllPrinter, Len(GetAllPrinter) - 2)
End Function
Unter Win7 habe ich es aber noch nicht getestet, unter XP funzt das aber.
Viele Gr��e
Michael
--
http://michael-schwimmer.de
Masterclass Excel VBA ISBN-10: 3827325250
Das Excel-VBA Codebook ISBN-10: 3827324718
Microsoft Office Excel 2007-Programmierung ISBN-10: 3866454139
Sepp, Salzburg
auch Dir meinen herzlichen Dank für Deine Mühe und die tolle Lösung.
Für mich gibt es noch viel zu lernen.
Beste Grüße
--
Sepp, Salzburg
"Michael Schwimmer" wrote:
> Hallo Sepp,
>
> Am Fri, 12 Feb 2010 09:49:01 -0800 schrieb Sepp, Salzburg:
>
> > Wird der PC oder der Drucker gewechselt ändert sich meistens der Bezug,
> > z.B von Ne03 auf Ne04, d.h. das Makro funktioniert nicht mehr und muss
> > angepasst werden.
>
> > Gibt es eine Möglichkeit den Code so zu erstellen, dass der Bezug immer
> > richtig ist?
>
> kannst ja mal probieren, ob folgendes funktioniert:
>
> Sub test1()
> Dim varPrinter As Variant
> For Each varPrinter In Split(GetAllPrinter(), vbCrLf)
> If InStr(1, varPrinter, "PDF") > 0 Then
> MsgBox varPrinter, vbInformation, "Mach was mit mir"
> Exit For
> End If
> Next
> End Sub
>
> Public Function GetAllPrinter( _
> Optional strOn As String = "auf") As String
> Dim objWMIService As Object
> Dim objQuery As Object
> Dim objItem As Object
> Dim strComputer As String
> Dim strPort As String
> Dim strPrinter As String
> Dim objShell As Object
> ' Position des Schlüssels in der Registry für die Portnummer
> Const Ports As String = _
> "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\" & _
> "CurrentVersion\PrinterPorts\"
> On Error Resume Next
> ' Objekt zum einfachen Zugriff auf die Registry erzeugen
> If strOn <> "" Then Set objShell = CreateObject("WScript.Shell")
> ' Rechnername für WMI
> strComputer = "." ' Lokal
> ' WMI-Objekt erzeugen
> Set objWMIService = GetObject("winmgmts:\\" & _
> strComputer & "\root\cimv2")
> ' WQL (WMI Query Language ) Abfrage starten
> Set objQuery = objWMIService.ExecQuery( _
> "Select * from Win32_PrinterConfiguration")
> ' Alle zurückgelieferten Elemente durchlaufen
> For Each objItem In objQuery
> strPrinter = objItem.name
> GetAllPrinter = GetAllPrinter & strPrinter
> If strOn <> "" Then
> ' Portname ermitteln
> strPort = Split(objShell.RegRead(Ports & strPrinter), ",")(1)
> ' und mitsamt Bindewort (hier 'auf') anhängen
> GetAllPrinter = GetAllPrinter & " " & strOn & " " & strPort
> End If
> ' Zeilenumbruch anhängen
> GetAllPrinter = GetAllPrinter & vbCrLf
> Next
> ' Um den letzten Zeilenumbruch kürzen
> GetAllPrinter = Left(GetAllPrinter, Len(GetAllPrinter) - 2)
> End Function
>
> Unter Win7 habe ich es aber noch nicht getestet, unter XP funzt das aber.
>
> Viele Grüße
> Michael
>
>
>
> --
> http://michael-schwimmer.de
> Masterclass Excel VBA ISBN-10: 3827325250
> Das Excel-VBA Codebook ISBN-10: 3827324718
> Microsoft Office Excel 2007-Programmierung ISBN-10: 3866454139
> .
>
Sepp, Salzburg
Lieber Andreas,
herzlichen Dank für Deine Mühe und die prompte Antwort.
Die Lösung funktioniert einwandfrei.
Beste Grüße
--
Sepp, Salzburg
"Andreas Killer" wrote:
> .
>
Sepp, Salzburg
Lieber Michael,
herzlichen Dank für Deine Mühe und die prompte Antwort. Manchmal kommen
Antwort buchstäblich zur gleichen Zeit.
Beste Grüße
--
Sepp, Salzburg
"Michael v. Fondern" wrote:
> .
>