Re: per VBA textbox anpassen an Schriftgrösse

Tech-Archive recommends: Repair Windows Errors & Optimize Windows Performance

Hallo Andreas,


Am Tue, 7 Apr 2009 03:46:24 -0700 (PDT) schrieb Andreas Killer:
Vielen Dank für den Code, geht leider nicht so wirklich.
Sub Test()
   Dim varPrinter    As Variant
   Dim strPrinter    As String

   varPrinter = GetAllPrinter
Liefert zwar die richtige Anzahl Drucker, aber nur 2 (die lokalen)
haben einen "Namen" der Rest ist "".

dann probieren wir es mal nur über WMI und lassen den Umweg über die
Registry weg:

Public Function GetAllPrinters() As Variant
Dim objWMIService As Object
Dim objQuery As Object
Dim objItem As Object
Dim strComputer As String
Dim strTemp As String
Dim astrTemp() As String
Dim varProp As Variant
Dim i As Long

On Error Resume Next

' WMI-Objekt erzeugen
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & _
strComputer & "\root\cimv2")

' Abfrage starten
Set objQuery = objWMIService.ExecQuery( _
"Select Name, PortName from Win32_Printer")

' Temp-Array redimensionieren
ReDim astrTemp(1 To objQuery.Count)

For Each objItem In objQuery
i = i + 1
strTemp = ""
For Each varProp In objItem.Properties_
If LCase(varProp.Name) = "name" Then
strTemp = varProp.Value & strTemp
End If
If LCase(varProp.Name) = "portname" Then
strTemp = strTemp & " auf " & varProp.Value
End If
Next

astrTemp(i) = strTemp

Next

' Ergebnis zurückgeben
GetAllPrinters = astrTemp

End Function

Wobei die 2 lokalen Drucker keine richtigen Drucker sind, der eine ist
"FreePDF XP" und der andere "Bluebeam PDF Printer".

Die gelten aber auch als Drucker.

Die Netzwerkdrucker heißen
\\hannt012.haensel.han\10
\\hannt012\27

Ich habe jetzt auf einem anderen Rechner auch mal einen Drucker
eingerichtet und freigegeben. Das funktioniert einwandfrei:

Sub Test()
Dim varPrinter As Variant
Dim strPrinter As String

' varPrinter = GetAllPrinters
' strPrinter = varPrinter(5)

' strPrinter = Application.ActivePrinter

strPrinter = "\\Terminator76-pc\HP Officejet 5600 series auf FILE:"

MsgBox GetPaper(strPrinter)

End Sub

Übergibt man an GetPaper den Druckernamen, wird die Papiergröße
zurückgeliefert. Eventuell musst du mal schauen, welche Berechtigungen
unter Sicherheit (Drucker-, Dokumente verwalten) vergeben sind.

Ich habe die Funktion GetPaper jetzt so geändert, dass der Portname darin
rausgeschmissen wird. Die Funktion schlägt dann aber fehl, wenn im
Druckernamen selbst (ohne Port) die Zeichenkette " auf " enthalten ist.
Außerdem ist garantiert das Wörtchen "auf" lokalisiert und bei anderen
Spracheinstellungen wird sicherlich etwas anderes verwendet.

Hier noch einmal der komplette Code:

Private Const CCHDEVICENAME As Long = 32
Private Const CCHFORMNAME As Long = 32
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
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 As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Type PRINTER_DEFAULTS
pDatatype As String
pDevMode As Long 'DEVMODE
DesiredAccess As Long
End Type
Private Declare Function OpenPrinter _
Lib "winspool.drv" Alias "OpenPrinterA" ( _
ByVal pstrPrinter As String, _
phPrinter As Long, _
pDefault As PRINTER_DEFAULTS _
) As Long
Private Declare Function ClosePrinter _
Lib "winspool.drv" ( _
ByVal hPrinter As Long _
) As Long
Private Declare Function GetPrinter _
Lib "winspool.drv" Alias "GetPrinterA" ( _
ByVal hPrinter As Long, _
ByVal Level As Long, _
pPrinter As Any, _
ByVal cbBuf As Long, _
pcblngLänge As Long _
) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Private Const PRINTER_ACCESS_ADMINISTER As Long = &H4
Private Const PRINTER_ACCESS_USE As Long = &H8
Private Const PRINTER_ALL_ACCESS As Long = ( _
STANDARD_RIGHTS_REQUIRED Or _
PRINTER_ACCESS_ADMINISTER Or _
PRINTER_ACCESS_USE)
Private Const DMPAPER_A2 As Long = 66
Private Const DMPAPER_A3 As Long = 8
Private Const DMPAPER_A4 As Long = 9
Private Const DMPAPER_A5 As Long = 11


Public Function GetPaper(ByVal strPrinter As String) As String
Dim arrBuffer() As Long
Dim lngLänge As Long
Dim udtDevMode As DEVMODE
Dim udtPrintDef As PRINTER_DEFAULTS
Dim lngRet As Long
Dim lngPtrDevMode As Long
Dim lngPrinter As Long
Dim i As Long
On Error Resume Next

' Funzt wahrscheinlich nur in DE
strPrinter = Split(strPrinter, " auf ")(0)

' Printer-Defaults-Struktur initialisieren
udtPrintDef.pDatatype = vbNullString
udtPrintDef.pDevMode = 0
udtPrintDef.DesiredAccess = PRINTER_ALL_ACCESS

' Printer öffnen
lngRet = OpenPrinter(strPrinter, lngPrinter, udtPrintDef)

If lngRet = 0 Then
If Err.LastDllError = 1801 Then
MsgBox "Falscher Druckername"
Else
MsgBox "Kein gültiger Drucker"
End If
Exit Function
End If

' Pufferlänge ermitteln
lngRet = GetPrinter(lngPrinter, 2, ByVal 0&, 0, lngLänge)

' Puffer anpassen
ReDim arrBuffer((lngLänge \ 4))

' Printerinfos ermitteln (Level 2)
lngRet = GetPrinter(lngPrinter, 2, _
arrBuffer(0), lngLänge, lngLänge)

' Drucker schließen
ClosePrinter lngPrinter

' Pointer auf die DEVMODE-Struktur
lngPtrDevMode = arrBuffer(7)

' Eigene DEVMODE-Struktur füllen
CopyMemory udtDevMode, ByVal lngPtrDevMode, Len(udtDevMode)

With udtDevMode ' Struktur auswerten

Select Case .dmPaperSize
Case DMPAPER_A2: GetPaper = "A2"
Case DMPAPER_A3: GetPaper = "A3"
Case DMPAPER_A4: GetPaper = "A4"
Case DMPAPER_A5: GetPaper = "A5"
Case Else
GetPaper = "Other"
End Select

GetPaper = GetPaper & vbCrLf & "Länge: " & .dmPaperLength & vbCrLf
GetPaper = GetPaper & "Breite: " & .dmPaperWidth

End With

End Function


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
.

Relevant Pages

  • Re: access report to PDF
    ... So long Dieter ... > Function EmailFormAsPDF(Email_adr As String) ... > Dim objOutlook As Outlook.Application ...
    (microsoft.public.de.access)
  • Probleme mit Rename Funktion in VB
    ... Public Function GetOrdner() As String ... Dim DataAs String ... Dim Count As Integer = 0 ...
    (microsoft.public.de.german.entwickler.dotnet.vb)
  • Re: IP Adresse mit VBA
    ... Private Declare Function gethostbyname Lib "WSOCK32.DLL" ... lpWSAData As WinSocketDataType) As Long ... End Type ... Dim LoBy%, HiBy% ...
    (microsoft.public.de.excel)
  • Re: Formel für:schreibe ein a wenn...
    ... >> ' Function: Returns the colorindex of the supplied range ... >> Dim cell As Range, ... >> Dim i As Long, ... >> End If ...
    (microsoft.public.de.excel)
  • Re: API-Calls gehen nicht mehr!
    ... Verweise (außer die in Access nicht entfernbaren auf Access10 und VBA) etc. ... Declare Function CopyMemory Lib "kernel32" _ ... Dim tmp1 As Long ...
    (microsoft.public.de.vb)