per VBA textbox anpassen an Schriftgrösse
Willy Steffen
Komme wiedereinmal nicht weiter und benötige Eure Hilfe. Nämlich will ich
eine Transparente Textbox, mit 90° gedrehtem Text und die sich automatisch an
die Textgrösse anpasst. Auch möchte ich den Namen der betroffenen Textbox in
eine Variable rsp Msg Box schreiben. Ich hoffe, dass man dies machen und mir
helfen kann.
Bemerkung:
In Zeile 2 in der Spalte der aktiven Zelle ist ein Kommentar "Feierttage"
der in das Textfeld eingetragen wird.
Hier den Code der fast funktioniert:
Sub Textfeld1()
'Dim X As Double, Y As Double
Dim AktZelle As Range
Dim txtBox As Shape
Dim ZellTXT As String, Nom
Dim Spalte As Long, Zeile
'Kommentar holen
Spalte = ActiveCell.Column
Zeile = ActiveCell.Row
ZellTXT = Cells(2, Spalte).Comment.Text
Set AktZelle = Cells(Zeile, Spalte)
Set txtBox = Tabelle1.Shapes.AddTextbox( _
msoTextOrientationUpward, AktZelle.Left, AktZelle.Top + 11, _
200, 200)
With txtBox.TextFrame.Characters
.Text = ZellTXT
End With
End Sub
Michael Schwimmer
Am Fri, 3 Apr 2009 16:06:00 -0700 schrieb Willy Steffen:
> Komme wiedereinmal nicht weiter und benötige Eure Hilfe. Nämlich will ich
> eine Transparente Textbox, mit 90° gedrehtem Text und die sich automatisch an
> die Textgrösse anpasst. Auch möchte ich den Namen der betroffenen Textbox in
> eine Variable rsp Msg Box schreiben. Ich hoffe, dass man dies machen und mir
> helfen kann.
Das mit dem Namen lässt sich leicht erledigen. Die Name-Eigenschaft ist
dafür zuständig. Hier dein etwas angepasste Code mit einem festen Text.
Sub Textfeld1()
Dim rngActCell As Range
Dim objShape As Shape
Dim strText As String
Dim lngSpalte As Long
Dim lngZeile As Long
lngSpalte = ActiveCell.Column
lngZeile = ActiveCell.Row
strText = "Hallo Welt"
Set rngActCell = Cells(lngZeile, lngSpalte)
Set objShape = Tabelle1.Shapes.AddTextbox( _
msoTextOrientationUpward, _
rngActCell.Left, _
rngActCell.Top + 11, _
200, 200)
MsgBox objShape.Name
With objShape.TextFrame.Characters
.Text = strText
End With
End Sub
Jetzt kommt der schwierige Teil. Mir ist nämlich keine in Excel oder VBA
eingebaute Funktion bekannt, welche die Größe ermittelt, die ein
vorgegebener Text einer bestimmten Größe und Schriftart in Punkt einnimmt.
Es gibt aber die API-Funktion GetTextExtentPoint, die die Abmessungen eines
virtuellen Textrahmens in Pixel ermittelt. Diese benötigt einen DC, also
einen Gerätekontext, in dem man Text hineinzeichnen kann. In diesem DC muss
auch noch die gewünschte Schriftart mit allen relevanten Eigenschaften
gestellt werden.
Man legt also mit CreateCompatibleDC einen zum Screen kompatiblen DC an,
erzeugt mit CreateFontIndirect eine Schriftart und stellt diese mit
SelectObjekt dort hinein. Zum Erzeugen der Schriftart muss die Struktur
LOGFONT ausgefüllt werden. Das Element lfHeight, was die Schriftgröße in
logischen Einheiten aufnimmt, ist das wichtigste für die Textgröße.
Um aus der Schriftgröße, die von Excel verwendet wird, eine in Logical
Units zu machen, muss man die vertikale (virtuelle) Auflösung kennen. Die
vertikale und horizontale ermittelt man mit der API GetDeviceCaps.
Nun füllt man in der LOGFONT-Struktur noch die Elemente für die
Texteigenschaften Bold und Italic aus. lfItalic ist ein Wahrheitswert,
während lfWeight ein Longwert ist, wobei 0 Standarddicke und 700 der Wert
für Fett ist. Das Bytearray lfFaceName nimmt die Schriftart auf.
Nach dem Aufruf von GetTextExtentPoint, wobei man als Parameter den DC, den
Text, die Textlänge und eine Struktur vom Typ Size übergibt, kann man aus
der der ausgefüllten Struktur die Abmessungen in Pixel auslesen.
Diese Werte müssen nun noch in Punkt umgewandelt und als Funktionsergebnis
zurückgegeben werden. Hier die Funktion zum Ermitteln der benötigten Größe:
Private Const LF_FACESIZE As Long = 32
Private Const FW_DONTCARE As Long = 0 ' Standard
Private Const FW_BOLD As Long = 700 ' fett
Private Type SIZE
cx As Long
cy As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Declare Function CreateCompatibleDC _
Lib "gdi32" ( _
ByVal hdc As Long _
) As Long
Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hdc As Long _
) As Long
Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long _
) As Long
Private Declare Function CreateFontIndirect _
Lib "gdi32" Alias "CreateFontIndirectA" ( _
lpLogFont As LOGFONT _
) As Long
Private Declare Function DeleteObject _
Lib "gdi32.dll" ( _
ByVal hObject As Long _
) As Long
Private Declare Function GetTextExtentPoint _
Lib "gdi32" Alias "GetTextExtentPointA" ( _
ByVal hdc As Long, _
ByVal lpszStr As String, _
ByVal cchString As Long, _
lpSize As SIZE _
) As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long _
) As Long
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Public Function GetTextExt( _
MyText As String, _
FontName As String, _
FontSize As Double, _
Optional Bold As Boolean, _
Optional Italic As Boolean, _
Optional Y As Boolean _
) As Double
Dim udtFont As LOGFONT
Dim lngFont As Long
Dim lngRet As Long
Dim lngDC As Long
Dim lngTextSize As Long
Dim udtSize As SIZE
Dim lngDpiX As Long
Dim lngDpiY As Long
Dim abytFontname() As Byte
Dim i As Long
On Error Resume Next
' Einen DC erzeugen, der kompatibel zum Bildschirm ist
lngDC = CreateCompatibleDC(0&)
' Pixel per logischen Inch in X-Richtung
lngDpiX = GetDeviceCaps(lngDC, LOGPIXELSX)
lngDpiY = GetDeviceCaps(lngDC, LOGPIXELSY)
' Schriftart in Bytearray umwandeln
abytFontname = StrConv(FontName & Chr$(0), vbFromUnicode)
' Texthöhe von Punkt in Logical Units umwandeln
lngTextSize = lngDpiY * FontSize / 72
' Eigenschaften der Schriftart setzen
With udtFont
.lfHeight = lngTextSize * -1
If Bold Then .lfWeight = FW_BOLD
If Italic Then .lfItalic = True
For i = 0 To UBound(abytFontname)
.lfFaceName(i) = abytFontname(i)
Next
End With
' Schrift mit eingestellten Eigenschaften erzeugen
lngFont = CreateFontIndirect(udtFont)
' Schrifteigenschaften in den DC bringen
SelectObject lngDC, lngFont
' Abmessungen des Textes in Pixel erfragen
lngRet = GetTextExtentPoint(lngDC, MyText, Len(MyText), udtSize)
' DC löschen
DeleteDC lngDC
' Schrift mit eingestellten Eigenschaften löschen
DeleteObject lngFont
' Abmessung in Punkt zurückgeben
If Y Then
GetTextExt = udtSize.cy * 72 / lngDpiY
Else
GetTextExt = udtSize.cx * 72 / lngDpiX
End If
End Function
Um nun das Textfeld selbst anzupassen, habe ich testweise folgende Prozedur
verwendet:
Private Sub cmdAnpassen_Click()
Dim objShape As Object
Dim objTextFrame As Object
Dim objCharacters As Object
Dim dblHeight As Double
Dim dblWidth As Double
Dim dblTextTop As Double
Dim dblTextBottom As Double
Dim dblTextLeft As Double
Dim dblTextRight As Double
Set objShape = Tabelle1.Shapes("Textfeld 7")
Set objTextFrame = objShape.TextFrame
Set objCharacters = objTextFrame.Characters
With objCharacters
dblHeight = GetTextExt( _
MyText:=.Text, _
FontName:=.Font.Name, _
FontSize:=.Font.SIZE, _
Bold:=.Font.Bold, _
Italic:=.Font.Italic, _
Y:=True)
dblWidth = GetTextExt( _
MyText:=.Text, _
FontName:=.Font.Name, _
FontSize:=.Font.SIZE, _
Bold:=.Font.Bold, _
Italic:=.Font.Italic, _
Y:=False)
End With
With objTextFrame
dblTextTop = .MarginTop
dblTextBottom = .MarginBottom
dblTextLeft = .MarginLeft
dblTextRight = .MarginRight
End With
objShape.Height = dblWidth + dblTextTop + dblTextBottom
objShape.Width = dblHeight + dblTextLeft + dblTextRight
End Sub
Die benutzten Namen müssen natürlich noch angepasst werden. Ich kann aber
nicht versprechen, dass es immer und überall funzt, ich habe eben nur auf
einem Rechner getestet. Gerade mit dem Umrechnen der Einheiten kommt man
immer wieder ins Schwitzen, da schleicht sich schnell ein schwer zu
findender Fehler ein.
Auch ist die Größe des Textframes nicht identisch mit den Abmessungen des
Shapes, hier muss eventuell noch etwas nachgebessert werden.
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
stefan onken
<WillyStef...@discussions.microsoft.com> wrote:
> Hallo NG's
> Komme wiedereinmal nicht weiter und benötige Eure Hilfe. Nämlich will ich
> eine Transparente Textbox, mit 90° gedrehtem Text und die sich automatisch an
> die Textgrösse anpasst.
hallo Willy,
so eine Textbox hat doch die Eigenschaft Automatische Größe
(rechtsklick auf den Rahmen, Textfeld formatieren).
Evtl reicht das ja. Der Code entsprechend angepasst:
Sub Textfeld1()
'Dim X As Double, Y As Double
Dim AktZelle As Range
Dim txtBox As Shape
Dim ZellTXT As String, Nom
Dim Spalte As Long, Zeile
'Kommentar holen
Spalte = ActiveCell.Column
Zeile = ActiveCell.Row
ZellTXT = Cells(2, Spalte).Comment.Text
Set AktZelle = Cells(Zeile, Spalte)
Set txtBox = Tabelle1.Shapes.AddTextbox( _
msoTextOrientationUpward, AktZelle.Left, _
AktZelle.Top + 11, _
200, 200)
With txtBox.TextFrame
.Characters.Text = ZellTXT
.AutoSize = True
End With
End Sub
Gruß
stefan
Andreas Killer
> Die benutzten Namen müssen natürlich noch angepasst werden. Ich kann aber
> nicht versprechen, dass es immer und überall funzt, ich habe eben nur auf
> einem Rechner getestet. Gerade mit dem Umrechnen der Einheiten kommt man
> immer wieder ins Schwitzen, da schleicht sich schnell ein schwer zu
> findender Fehler ein.
>
> Auch ist die Größe des Textframes nicht identisch mit den Abmessungen des
> Shapes, hier muss eventuell noch etwas nachgebessert werden.
Ja definitiv, denn je nach Ausrichtung
.Orientation = msoTextOrientationHorizontal passt es recht gut
.Orientation = msoTextOrientationDownward viel zu breit
.Orientation = msoTextOrientationVertical völlig daneben
gibt es da bei mir Unterschiede. Bei anderen Schriftgrößen sieht's
teilweise besser, teilweise noch schlimmer aus.
Andreas.
Eberhard Funke
Hallo Stefan,
> so eine Textbox hat doch die Eigenschaft Automatische Größe
> (rechtsklick auf den Rahmen, Textfeld formatieren).
Kann es sein, dass es dieses Feature erst bei XL >2000 gibt?
Bei mir kommt auf den Rechtsklick --> Textfeld_formatieren --> Grösse
und die kann ich ddort nur manuell einstellen.
> ZellTXT = Cells(2, Spalte).Comment.Text
ZellTXT = Cells(Zeile, Spalte).Comment.Text
> End With
Hier würde ich noch einfügen:
AktZelle.ClearComments
> End Sub
--
Mit freundlichen Grüssen Eberhard
XP home XL 2000
Eberhard(punkt)W(punkt)Funke(at)t-online.de
Eberhard Funke
Hallo Stefan,
> ZellTXT = Cells(Zeile, Spalte).Comment.Text
oder direkt mit ActiveCell:
Sub Textfeld1()
Dim ZellTXT As String
Dim txtBox As Shape
ZellTXT = ActiveCell.Comment.Text
Set txtBox = Tabelle1.Shapes.AddTextbox( _
msoTextOrientationUpward, ActiveCell.Left, _
ActiveCell.Top + 11, _
200, 200)
With txtBox.TextFrame
.Characters.Text = ZellTXT
.AutoSize = True
End With
ActiveCell.ClearComments
Michael Franke
> Kann es sein, dass es dieses Feature erst bei XL >2000 gibt?
> Bei mir kommt auf den Rechtsklick --> Textfeld_formatieren --> Grösse
> und die kann ich ddort nur manuell einstellen.
probier mal Rechtsklick --> Eigenschaften --> AutoSize = True (geht
auch über das Eigenschaftenfenster im VBA-Editor).
Gruß, Michael
stefan onken
> Kann es sein, dass es dieses Feature erst bei XL >2000 gibt?
> Bei mir kommt auf den Rechtsklick --> Textfeld_formatieren --> Grösse
> und die kann ich ddort nur manuell einstellen.
du musst den Rechtsklick auf dem Rahmen des Textfeldes machen, nicht
im Textfeld.
Der Mauscursor ändert sich in 4 Pfeile, wenn er auf dem Rahmen ist.
Oder linksklick im Textfeld, dann erscheint ein dickerer Rahmen,
darauf rechtsklicken.
Automatische Größe ist dann im Register Ausrichtung.
Es kann aber durchaus sein, dass es das unter XL2000 noch nicht gibt.
Gruß
stefan
Michael Schwimmer
Am Sun, 05 Apr 2009 10:33:33 +0200 schrieb Andreas Killer:
> Michael Schwimmer schrieb:
>> Auch ist die Größe des Textframes nicht identisch mit den Abmessungen des
>> Shapes, hier muss eventuell noch etwas nachgebessert werden.
> Ja definitiv, denn je nach Ausrichtung
>
> .Orientation = msoTextOrientationHorizontal passt es recht gut
> .Orientation = msoTextOrientationDownward viel zu breit
> .Orientation = msoTextOrientationVertical völlig daneben
es ging beim OP eigentlich um msoTextOrientationUpward und damit hatte ich
getestet:
Set txtBox = Tabelle1.Shapes.AddTextbox( _
msoTextOrientationUpward, AktZelle.Left, AktZelle.Top + 11, _
200, 200)
Du hast aber recht, dass es mit den anderen Ausrichtungen Probleme gibt.
Excel setzt je nach Textausrichtung beim Einfügen des Shapes die folgenden
Eigenschaften unterschiedlich:
MarginTop
MarginBottom
MarginLeft
MarginRight
Da hilft es zum Teil schon, diese Eigenschaften etwas anzupassen, ist aber
letztendlich auch stark von der Schriftart und möglicherweise auch von der
Excel-Version abhängig. Einige Adjustments-Eigenschaften von Shapes sind in
Excel 2007 jedenfalls auch unterschiedlich zu vorangegangenen Versionen.
Private Sub cmdAnpassen_Click()
Dim objShape As Object
Dim objTextFrame As Object
Dim objCharacters As Object
Dim dblHeight As Double
Dim dblWidth As Double
Dim dblTextTop As Double
Dim dblTextBottom As Double
Dim dblTextLeft As Double
Dim dblTextRight As Double
Dim dblOffsetVer As Double
Dim dblOffsetHor As Double
Set objShape = Tabelle1.Shapes("Textfeld 1")
Set objTextFrame = objShape.TextFrame
Set objCharacters = objTextFrame.Characters
With objCharacters
dblHeight = GetTextExt( _
MyText:=.Text, _
FontName:=.Font.Name, _
FontSize:=.Font.SIZE, _
Bold:=.Font.Bold, _
Italic:=.Font.Italic, _
Y:=True)
dblWidth = GetTextExt( _
MyText:=.Text, _
FontName:=.Font.Name, _
FontSize:=.Font.SIZE, _
Bold:=.Font.Bold, _
Italic:=.Font.Italic, _
Y:=False)
End With
With objTextFrame
Select Case objTextFrame.Orientation
Case msoTextOrientationDownward
.MarginTop = 3
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
dblOffsetVer = 0
dblOffsetHor = 0
Case msoTextOrientationUpward
.MarginTop = 0
.MarginBottom = 3
.MarginLeft = 0
.MarginRight = 0
dblOffsetVer = 0
dblOffsetHor = 0
Case msoTextOrientationVertical, _
msoTextOrientationVerticalFarEast
.MarginTop = 3
.MarginBottom = 2
.MarginLeft = 2
.MarginRight = 0
dblOffsetVer = 0
dblOffsetHor = 0
Case msoTextOrientationHorizontal
.MarginTop = 0
.MarginBottom = 6
.MarginLeft = 2
.MarginRight = 0
dblOffsetVer = 0
dblOffsetHor = 4
Case msoTextOrientationHorizontalRotatedFarEast
dblWidth = .Characters.Font.SIZE * 1.5 * .Characters.Count
.MarginTop = 0
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
dblOffsetVer = 0
dblOffsetHor = 4
End Select
dblTextTop = .MarginTop
dblTextBottom = .MarginBottom
dblTextLeft = .MarginLeft
dblTextRight = .MarginRight
End With
Select Case objTextFrame.Orientation
Case _
msoTextOrientationDownward, _
msoTextOrientationUpward, _
msoTextOrientationVertical, _
msoTextOrientationVerticalFarEast, _
msoTextOrientationHorizontalRotatedFarEast
objShape.Height = dblWidth + dblTextTop + _
dblTextBottom + dblOffsetVer
objShape.Width = dblHeight + dblTextLeft + _
dblTextRight + dblOffsetHor
Case msoTextOrientationHorizontal
objShape.Height = dblHeight + dblTextTop + _
dblTextBottom + dblOffsetVer
objShape.Width = dblWidth + dblTextTop + _
dblTextBottom + dblOffsetHor
End Select
End Sub
> gibt es da bei mir Unterschiede. Bei anderen Schriftgrößen sieht's
> teilweise besser, teilweise noch schlimmer aus.
Selbst wenn man die Margin-Eigenschaften alle auf Null setzt, gibt es bei
den unterschiedlichen Schriftarten gravierende Unterschiede. Das kann man
erkennen, wenn man einmal mit Andy formatiert, das Shape händisch anpasst
und anschließend beispielsweise Bauhaus 93 wählt. Bei gleichen Margin- und
Schriftgradeigenschaften (Höhe der Schrift) ist ist der Abstand vom oberem
Rand unterschiedlich.
Die Funktion GetTextExtentPoint ermittelt lediglich die Abmessungen in
Pixel, die ein Bereich haben muss, um den Text in den übergebenen DC mit
den angegebenen Eigenschaften zu zeichnen.
Die einzige befriedigende Lösung ist sicherlich nur AutoSize, wusste gar
nicht, dass es die gibt. Soll doch Excel entscheiden, wie groß der Kram
sein muss!
Eberhard Funke
Danke Stefan,
> Automatische Größe ist dann im Register Ausrichtung.
... und nicht im Register "Größe", wo ich es sinnvollerweise vermutet und
vergeblich gesucht hatte. :-(
Eberhard Funke
Danke Michael,
es ging um das Fenster Textfeld_formatieren, um dort die Autogrösse
einzustellen (s. fooowup-Posting Stefan).
Andreas Killer
> Die Funktion GetTextExtentPoint ermittelt lediglich die Abmessungen in
> Pixel, die ein Bereich haben muss, um den Text in den übergebenen DC mit
> den angegebenen Eigenschaften zu zeichnen.
Mal so nebenbei:
Ich hatte auch schon mal mit GetDeviceCaps rumprobiert um die
Papiergröße vor dem Drucken zu ermitteln wenn
ActiveSheet.PageSetup.PaperSize = xlPaperUser ist.
Allerdings krieg ich es nicht gebacken eine Liste der Drucker zu
erstellen, bzw. den aktuellen Drucker zu ermitteln. z.B. diese Routine
funzt nicht, weil schon GetProfileString("WINDOWS", "DEVICE",... keine
Ergebnisse liefert. (Wahrscheinlich wegen der Netzwerkdrucker???)
Gibt's da eigentliche noch ein anderes Verfahren?
Andreas.
Sub Command1_Click()
' Me.Show
' form1.Cls
' form1.Caption = "Printer Device Capabilities"
Dim szprinter$
' Get printer information from WIN.INI:
szprinter$ = Space$(128)
A% = GetProfileString("WINDOWS", "DEVICE", "", szprinter$, 64)
a1$ = Left$(szprinter$, A%) ' These lines find the commas in
the text
a2% = InStr(a1$, ",") ' and strip them out.
Print_device$ = Left$(a1$, a2% - 1)
' Hold printer device info
Debug.Print "Printer = ", Print_device$
a3$ = Mid$(a1$, a2% + 1)
a4% = InStr(a3$, ",")
driver$ = Left$(a3$, a4% - 1) ' Hold printer driver info.
Debug.Print "Driver = ", driver$
port$ = Mid$(a1$, a2% + a4% + 1) ' Hold printer port info.
Debug.Print "Port = ", port$
a5% = CreateIC(driver$, Print_device$, port$, 0)
a6% = GetDeviceCaps(a5%, 0)
Debug.Print "Driver Version : "; Hex$(a6%)
Debug.Print
z1% = Get_Device_Information(a5%)
finished% = DeleteDC(a5%)
End Sub
Michael Schwimmer
Am Mon, 06 Apr 2009 17:51:18 +0200 schrieb Andreas Killer:
> Ich hatte auch schon mal mit GetDeviceCaps rumprobiert um die
> Papiergröße vor dem Drucken zu ermitteln wenn
> ActiveSheet.PageSetup.PaperSize = xlPaperUser ist.
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
' 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 MsgBox "Kein gültiger Drucker": Exit Function
' 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
> Allerdings krieg ich es nicht gebacken eine Liste der Drucker zu
> erstellen, bzw. den aktuellen Drucker zu ermitteln. z.B. diese Routine
> funzt nicht, weil schon GetProfileString("WINDOWS", "DEVICE",... keine
> Ergebnisse liefert. (Wahrscheinlich wegen der Netzwerkdrucker???)
> Gibt's da eigentliche noch ein anderes Verfahren?
Sub Test()
Dim varPrinter As Variant
Dim strPrinter As String
varPrinter = GetAllPrinter
strPrinter = varPrinter(1)
' strPrinter = Application.ActivePrinter
strPrinter = Split(strPrinter, " auf ")(0)
MsgBox GetPaper(strPrinter)
End Sub
Public Function GetAllPrinter(Optional blnPort As Boolean = True) _
As Variant
Dim objWMIService As Object
Dim objQuery As Object
Dim objItem As Object
Dim strComputer As String
Dim objShell As Object
Dim strTemp As String
Dim astrTemp() As String
Dim i As Long
Const Ports As String = _
"HKEY_CURRENT_USER\Software\Microsoft\Windows NT\" & _
"CurrentVersion\PrinterPorts\"
On Error Resume Next
' WMI-Objekt erzeugen
Set objShell = CreateObject("WScript.Shell")
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & _
strComputer & "\root\cimv2")
' Abfrage starten
Set objQuery = objWMIService.ExecQuery( _
"Select * from Win32_PrinterConfiguration")
' Temp-Array redimensionieren
ReDim astrTemp(1 To objQuery.Count)
For Each objItem In objQuery
i = i + 1
' Name und den aus der Registry ausgelesenen Port im
' Array speichern
If blnPort Then
astrTemp(i) = objItem.Name & " auf " & _
Split(objShell.RegRead(Ports & objItem.Name), ",")(1)
Else
astrTemp(i) = objItem.Name
End If
Next
' Ergebnis zurückgeben
GetAllPrinter = astrTemp
End Function
Andreas Killer
wrote:
> > Ich hatte auch schon mal mit GetDeviceCaps rumprobiert um die
> > Papiergröße vor dem Drucken zu ermitteln wenn
> > ActiveSheet.PageSetup.PaperSize = xlPaperUser ist.
> Private Const CCHDEVICENAME As Long = 32
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 "".
Wobei die 2 lokalen Drucker keine richtigen Drucker sind, der eine ist
"FreePDF XP" und der andere "Bluebeam PDF Printer".
Die Netzwerkdrucker heißen
\\hannt012.haensel.han\10
\\hannt012\27
> Public Function GetAllPrinter(Optional blnPort As Boolean = True) _
...
> Const Ports As String = _
> "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\" & _
> "CurrentVersion\PrinterPorts\"
> astrTemp(i) = objItem.Name & " auf " & _
> Split(objShell.RegRead(Ports & objItem.Name), ",")(1)
Den HKEY gibt es, hab ich von Hand nachgekuckt, allerdings mit den
dusseligen Druckernamen gibts dann den Fehler "Ungültige Wurzel in
Registrierungsschlüssel".
Also der KEY "\\hannt012\27" hat z.B. den Wert "winspool,Ne03:,15,45"
Und strPrinter = Application.ActivePrinter gibt mir "\\hannt012\27 auf
Ne03:" zurück.
> Public Function GetPaper(ByVal strPrinter As String) As String
...
> ' Printer öffnen
> lngRet = OpenPrinter(strPrinter, lngPrinter, udtPrintDef)
Hier gibt's bei mir immer eine 0, egal welchen Drucker ich nehme.
Irgendeine Idee wie ich GetPaper("\\hannt012.haensel.han\10") zum
laufen kriege?
Andreas.
Michael Schwimmer
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
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
Michael Schwimmer
Am Tue, 7 Apr 2009 15:48:59 +0200 schrieb Michael Schwimmer:
> dann probieren wir es mal nur über WMI und lassen den Umweg über die
> Registry weg:
noch etwas konsequenter, alles mit WMI:
Sub InfosAuslesen()
Dim varPrinter As Variant
Dim VarSettings As Variant
Dim varTemp As Variant
Dim strPrinter As String
varPrinter = GetAllPrinters
If IsArray(varPrinter) Then
For Each varTemp In varPrinter
Debug.Print varTemp
Next
End If
Debug.Print ""
strPrinter = varPrinter(5)
' strPrinter = Application.ActivePrinter
' strPrinter = "\\Terminator76-pc\HP Officejet 5600 series auf FILE:"
VarSettings = GetPrinterInfos(strPrinter)
If IsArray(VarSettings) Then
For Each varTemp In VarSettings
Debug.Print varTemp
Next
End If
End Sub
Private Function GetPrinterInfos( _
strPrinter As String) As Variant
Dim objClass As Object
Dim objItem As Object
Dim objProperties As Object
Dim strOut As String
Dim astrRet() As String
Dim strClass As String
Dim i As Long
On Error Resume Next
' Funzt wahrscheinlich nur in DE
strPrinter = Split(strPrinter, " auf ")(0)
strClass = "Win32_PrinterConfiguration"
strPrinter = " Where Name='" & Replace(strPrinter, "\", "\\") & "'"
' Zugriff auf die Klasse
Set objClass = GetObject("winmgmts://./root/cimv2" _
).ExecQuery("SELECT * FROM " & strClass & _
strPrinter)
For Each objItem In objClass
' Alle Eigenschaften durchlaufen
ReDim astrRet(1 To objItem.Properties_.Count)
For Each objProperties In objItem.Properties_
With objProperties
i = i + 1
' Wert und Name dieser Eigenschaft auslesen
astrRet(i) = .Name & ":= " & .Value
End With
Next objProperties
Next objItem
If i > 0 Then GetPrinterInfos = astrRet
End Function
Das Ergebnis sieht bei mir so aus:
t@x PDF Converter auf LPT1:
Microsoft XPS Document Writer auf XPSPort:
HP Officejet 5600 series fax auf USB001
HP Officejet 5600 series auf USB001
\\TERMINATOR76-PC\HP Officejet 5600 series auf FILE:
BitsPerPel:=
Caption:= \\TERMINATOR76-PC\HP Officejet
Collate:= Wahr
Color:= 2
Copies:= 1
Description:= \\TERMINATOR76-PC\HP Officejet 5600 series
DeviceName:= \\TERMINATOR76-PC\HP Officejet
DisplayFlags:=
DisplayFrequency:=
DitherType:= -1
DriverVersion:= 1536
Duplex:=
FormName:=
HorizontalResolution:= 600
ICMIntent:= 2
ICMMethod:= 1
LogPixels:=
MediaType:= 273
Name:= \\TERMINATOR76-PC\HP Officejet 5600 series
Orientation:= 1
PaperLength:= 2970
PaperSize:= 9
PaperWidth:= 2100
PelsHeight:=
PelsWidth:=
PrintQuality:= 600
Scale:=
SettingID:= \\TERMINATOR76-PC\HP Officejet
SpecificationVersion:= 1025
TTOption:= 2
VerticalResolution:= 600
XResolution:= 600
YResolution:= 600
Andreas Killer
> Am Tue, 7 Apr 2009 15:48:59 +0200 schrieb Michael Schwimmer:
>> dann probieren wir es mal nur über WMI und lassen den Umweg über die
>> Registry weg:
> noch etwas konsequenter, alles mit WMI:
Ja, bei mir zu Hause sieht's nun schon besser aus, morgen schau ich
auf der Arbeit nochmal. Es fehlen zwar einige Angaben (weil der
Treiber sie nicht unterstützt?), aber die wichtige Papiergröße ist
drin, das zählt.
Andreas.
Samsung CLP-310 Series auf USB001
Microsoft XPS Document Writer auf XPSPort:
BitsPerPel:=
Caption:= Samsung CLP-310 Series
Collate:= Wahr
Color:= 2
Copies:= 1
Description:= Samsung CLP-310 Series
DeviceName:= Samsung CLP-310 Series
DisplayFlags:=
DisplayFrequency:=
DitherType:=
DriverVersion:= 1024
Duplex:= Falsch
FormName:=
HorizontalResolution:=
ICMIntent:= 2
ICMMethod:= 1
LogPixels:=
MediaType:=
Name:= Samsung CLP-310 Series
Orientation:= 1
PaperLength:= 2970
PaperSize:= 9
PaperWidth:= 2100
PelsHeight:=
PelsWidth:=
PrintQuality:= 600
Scale:=
SettingID:= Samsung CLP-310 Series
SpecificationVersion:= 1025
TTOption:= 3
VerticalResolution:=
XResolution:=
YResolution:=
Andreas Killer
wrote:
Guten Morgen, Michael.
> Sub InfosAuslesen()
So ich hab grad probiert, die Drucker werden alle erkannt, die Detail-
Angaben kommen auch recht gut, nur wenn ich eine benutzerdefnierte
Papiergröße einstelle, dann kommt Papersize = 132 , das ist genau das
was mit Excel ActiveSheet.PageSetup.PaperSize auch bekomme. Aber wie
groß das ist???
Noch'ne Idee?
Andreas.
FreePDF XP auf FreePDFXP1:
Bluebeam PDF Printer auf BLUEBEAMPDFPORT
\\hannt012.haensel.han\10 auf \\hannt012.haensel.han\10
\\hannt012\27 auf IP_10.0.1.128
BitsPerPel:=
Caption:= \\hannt012\27
Collate:=
Color:= 2
Copies:= 1
Description:= \\hannt012\27
DeviceName:= \\hannt012\27
DisplayFlags:=
DisplayFrequency:=
DitherType:=
DriverVersion:= 24
Duplex:= Falsch
FormName:=
HorizontalResolution:= 600
ICMIntent:=
ICMMethod:= 1
LogPixels:=
MediaType:=
Name:= \\hannt012\27
Orientation:= 1
PaperLength:=
PaperSize:= 132
PaperWidth:=
PelsHeight:=
PelsWidth:=
PrintQuality:= 600
Scale:=
SettingID:= \\hannt012\27
SpecificationVersion:= 1025
TTOption:=
Michael Schwimmer
Am Wed, 8 Apr 2009 00:14:26 -0700 (PDT) schrieb Andreas Killer:
> So ich hab grad probiert, die Drucker werden alle erkannt, die Detail-
> Angaben kommen auch recht gut, nur wenn ich eine benutzerdefnierte
> Papiergr��e einstelle, dann kommt Papersize = 132 , das ist genau das
> was mit Excel ActiveSheet.PageSetup.PaperSize auch bekomme. Aber wie
> gro� das ist???
ich kenne nur die folgenden Konstanten aus den Header-Dateien:
Const DMPAPER_LETTER = 1
Const DMPAPER_FIRST = DMPAPER_LETTER ' Letter 8 1/2 x 11 in
Const DMPAPER_LETTERSMALL = 2 ' Letter Small 8 1/2 x 11 in
Const DMPAPER_TABLOID = 3 ' Tabloid 11 x 17 in
Const DMPAPER_LEDGER = 4 ' Ledger 17 x 11 in
Const DMPAPER_LEGAL = 5 ' Legal 8 1/2 x 14 in
Const DMPAPER_STATEMENT = 6 ' Statement 5 1/2 x 8 1/2 in
Const DMPAPER_EXECUTIVE = 7 ' Executive 7 1/4 x 10 1/2 in
Const DMPAPER_A3 = 8 ' A3 297 x 420 mm
Const DMPAPER_A4 = 9 ' A4 210 x 297 mm
Const DMPAPER_A4SMALL = 10 ' A4 Small 210 x 297 mm
Const DMPAPER_A5 = 11 ' A5 148 x 210 mm
Const DMPAPER_B4 = 12 ' B4 250 x 354
Const DMPAPER_B5 = 13 ' B5 182 x 257 mm
Const DMPAPER_FOLIO = 14 ' Folio 8 1/2 x 13 in
Const DMPAPER_QUARTO = 15 ' Quarto 215 x 275 mm
Const DMPAPER_10X14 = 16 ' 10x14 in
Const DMPAPER_11X17 = 17 ' 11x17 in
Const DMPAPER_NOTE = 18 ' Note 8 1/2 x 11 in
Const DMPAPER_ENV_9 = 19 ' Envelope #9 3 7/8 x 8 7/8
Const DMPAPER_ENV_10 = 20 ' Envelope #10 4 1/8 x 9 1/2
Const DMPAPER_ENV_11 = 21 ' Envelope #11 4 1/2 x 10 3/8
Const DMPAPER_ENV_12 = 22 ' Envelope #12 4 \276 x 11
Const DMPAPER_ENV_14 = 23 ' Envelope #14 5 x 11 1/2
Const DMPAPER_CSHEET = 24 ' C size sheet
Const DMPAPER_DSHEET = 25 ' D size sheet
Const DMPAPER_ESHEET = 26 ' E size sheet
Const DMPAPER_ENV_DL = 27 ' Envelope DL 110 x 220mm
Const DMPAPER_ENV_C5 = 28 ' Envelope C5 162 x 229 mm
Const DMPAPER_ENV_C3 = 29 ' Envelope C3 324 x 458 mm
Const DMPAPER_ENV_C4 = 30 ' Envelope C4 229 x 324 mm
Const DMPAPER_ENV_C6 = 31 ' Envelope C6 114 x 162 mm
Const DMPAPER_ENV_C65 = 32 ' Envelope C65 114 x 229 mm
Const DMPAPER_ENV_B4 = 33 ' Envelope B4 250 x 353 mm
Const DMPAPER_ENV_B5 = 34 ' Envelope B5 176 x 250 mm
Const DMPAPER_ENV_B6 = 35 ' Envelope B6 176 x 125 mm
Const DMPAPER_ENV_ITALY = 36 ' Envelope 110 x 230 mm
Const DMPAPER_ENV_MONARCH = 37 ' Envelope Monarch 3.875 x 7.5 in
Const DMPAPER_ENV_PERSONAL = 38 ' 6 3/4 Envelope 3 5/8 x 6 1/2 in
Const DMPAPER_FANFOLD_US = 39 ' US Std Fanfold 14 7/8 x 11 in
Const DMPAPER_FANFOLD_STD_GERMAN = 40 ' German Std Fanfold 8 1/2 x 12
in
Const DMPAPER_FANFOLD_LGL_GERMAN = 41 ' German Legal Fanfold 8 1/2 x 13
in
Const DMPAPER_USER = 256 ' Benutzerdefiniert
M�glicherweise (11 x 13.2 inches). Schau doch mal nach, ob die 132
irgendein Ma� sein k�nnte, beispielsweise in 1/10 mm oder 1/10 inches.
Viele Gr��e
Andreas Killer
wrote:
> > Papiergr e einstelle, dann kommt Papersize = 132 , das ist genau das
> > was mit Excel ActiveSheet.PageSetup.PaperSize auch bekomme. Aber wie
> > gro das ist???
> M glicherweise (11 x 13.2 inches). Schau doch mal nach, ob die 132
> irgendein Ma sein k nnte, beispielsweise in 1/10 mm oder 1/10 inches.
Also das ist 8,5x13 inch, bzw. 216x330mm, tja...?
Gibt Dein Drucker auch eine 132 zurück wenn Du dies benutzerdefinierte
Papier einstellst?
Andreas.
Willy Steffen
Da habe ich wohl eine Diskussion losgetreten, die es in sich hat. Ich danke
Dir für Deine ausführliche Darstellung und werde mich durchackern. Ich werde
als Anfänger hier schön zu kauen haben. Das macht die Sache ja auch
interessant.
Nun ich habe vorläufig mit dem folgenden Code einigermassen für diesen Fall
akzeptierbaren Code gefunden.
Mit dem Autosize war ich nicht zufrieden, da die Spalte kleiner war als die
2 Textlinien und vergrössern wollte ich diese Spalte nicht.
Hier den Code:
Sub Textfeld1()
Dim X As Object
Dim AktZelle As Range
Dim txtBox As Shape, TXTBoxName
Dim ZellTXT As String, Nom
Dim Spalte As Long, Zeile
'Kommentar holen
Spalte = ActiveCell.Column
Zeile = ActiveCell.Row
ZellTXT = Cells(2, Spalte).Comment.Text
'Textbox an Zellen positionieren
Set AktZelle = Cells(Zeile, Spalte)
'TXTboxbreite bestimmen
Set X = Columns(Spalte)
'Textboxvariablen setzten
Set txtBox = Worksheets(1).Shapes.AddTextbox( _
msoTextOrientationUpward, AktZelle.Left, AktZelle.Top + 15, _
X.Width - 1, 105)
'Textfeld setzen und TXTboxname speichern
With txtBox.TextFrame.Characters
.Text = ZellTXT
.Font.Name = "Arial"
.Font.Size = 8
.Font.Background = xlBackgroundAutomatic ' xlBackgroundTransparent
TXTBoxName = .Parent.Name
End With
Print txtBox; wählen
ActiveSheet.Shapes(TXTBoxName).Select
'Text ausrichten
With Selection
'.AutoSize = True
.HorizontalAlignment = xlLeft 'xlRight
.VerticalAlignment = xlVAlignBottom 'xlVAlignBottomCenter
End With
'Formatierung der TXTbox
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.TextFrame.MarginLeft = 0#
Selection.ShapeRange.TextFrame.MarginRight = 0#
Selection.ShapeRange.TextFrame.MarginTop = 0#
Selection.ShapeRange.TextFrame.MarginBottom = 0#
'Vorherige Zelle wieder aktivieren
Cells(Zeile, Spalte).Activate
End Sub
Vielen Dank auf jeden Fall an Alle. Ich bin mit diesem Thema sicherlich noch
nicht durch.
Tschüss und schöne Ostern.
Willy
"Michael Schwimmer" schrieb:
Willy Steffen
Ich habe doch noch eine Frage um die Länge des Textfeldes zu definieren. Die
Width-Grösse habe ich ja gefunden.
Ist es denkbar z.b. den Kommentartext in eine Zelle eines freien
Tabellenblattes mit Schriftgrösse 8 zu schreiben und dann die Zelle
automatisch an die Schrift anpassen, dann die Zellenlänge abfragen und dieses
Mass für die Textfeldgrösse verwenden?
Ich danke Dir im Voraus für Deine Bemühungen.
Willy
"Michael Schwimmer" schrieb:
Michael Schwimmer
Am Wed, 8 Apr 2009 03:07:46 -0700 (PDT) schrieb Andreas Killer:
> Gibt Dein Drucker auch eine 132 zurück wenn Du dies benutzerdefinierte
> Papier einstellst?
bei meinen Tests habe ich für Benutzerdefiniert1 291, für
Benutzerdefiniert2 292 ... bekommen. Mit den Angaben für Länge und Breite
kann ich dann auch nichts mehr anfangen, bzw. habe noch kein System
dahinter entdeckt, es sind zum Teil sehr hohe, auch negative Angaben.
Viele Grüße
Michael Schwimmer
Am Fri, 10 Apr 2009 10:21:04 -0700 schrieb Willy Steffen:
> Ich habe doch noch eine Frage um die Länge des Textfeldes zu definieren. Die
> Width-Grösse habe ich ja gefunden.
> Ist es denkbar z.b. den Kommentartext in eine Zelle eines freien
> Tabellenblattes mit Schriftgrösse 8 zu schreiben und dann die Zelle
> automatisch an die Schrift anpassen, dann die Zellenlänge abfragen und dieses
> Mass für die Textfeldgrösse verwenden?
klar kann man das machen, bereitet mir persönlich aber Zahnschmerzen. Es
ist einfach nicht schön, Zellen zu ändern, um an irgendwelche Maße zu
kommen.
Sub test()
Dim objShape As Object
Dim objCharacters As Object
Set objShape = Tabelle1.Shapes.AddTextbox( _
msoTextOrientationVertical, _
ActiveCell.Left, _
ActiveCell.Top + 11, _
200, 50)
objShape.Name = "Textfeld 1"
With objShape.TextFrame.Characters
.Text = "Hallo Welt"
.Font.Color = RGB(255, 0, 0)
.Font.SIZE = 8
.Font.Bold = False
.Font.Italic = False
.Font.Name = "Arial"
End With
TextfeldAnpassen objShape, Worksheets("Tabelle2").Range("A1")
End Sub
Public Sub TextfeldAnpassen(Textfeld As Shape, Dummyzelle As Range)
With Textfeld.TextFrame
.MarginTop = 0
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
Dummyzelle.Value = .Characters.Text
Dummyzelle.Font.SIZE = .Characters.Font.SIZE
Dummyzelle.Font.Bold = .Characters.Font.Bold
Dummyzelle.Font.Italic = .Characters.Font.Italic
Dummyzelle.Font.Name = .Characters.Font.Name
Textfeld.Width = .Characters.Font.SIZE
End With
Dummyzelle.Columns.AutoFit
Textfeld.Height = Dummyzelle.Width
Dummyzelle.Delete Shift:=xlToLeft
End Sub
Man hat nur nicht viel gewonnen, das funktioniert auch immer nur für eine
bestimmte Ausrichtung, Schriftart und Schriftgröße. Die Eigenschaften
.MarginTop
.MarginBottom
.MarginLeft
.MarginRight
müssen immer noch von Fall zu Fall angepasst werden.
Andreas Killer
wrote:
> > Gibt Dein Drucker auch eine 132 zurück wenn Du dies benutzerdefinierte
> > Papier einstellst?
> bei meinen Tests habe ich für Benutzerdefiniert1 291, für
> Benutzerdefiniert2 292 ... bekommen. Mit den Angaben für Länge und Breite
> kann ich dann auch nichts mehr anfangen, bzw. habe noch kein System
> dahinter entdeckt, es sind zum Teil sehr hohe, auch negative Angaben.
Aha, okay, dann geht's halt nicht. Trotzdem vielen Dank für Deine
Mühe.
Andreas.
Michael Schwimmer
Am Tue, 14 Apr 2009 00:13:50 -0700 (PDT) schrieb Andreas Killer:
>> bei meinen Tests habe ich für Benutzerdefiniert1 291, für
>> Benutzerdefiniert2 292 ... bekommen. Mit den Angaben für Länge und Breite
>> kann ich dann auch nichts mehr anfangen, bzw. habe noch kein System
>> dahinter entdeckt, es sind zum Teil sehr hohe, auch negative Angaben.
> Aha, okay, dann geht's halt nicht. Trotzdem vielen Dank für Deine
> Mühe.
so schnell schmeißen wir die Flinte aber nicht ins Korn. Folgendes hat mir
auch bei bei benutzerdefinierten Größen die richtigen Werte geliefert.
Option Explicit
Private Declare Function OpenPrinter _
Lib "winspool.drv" Alias "OpenPrinterA" ( _
ByVal pstrPrinter As String, _
phPrinter As Long, _
pDefault As Long _
) 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 Declare Function DeviceCapabilities _
Lib "winspool.drv" Alias "DeviceCapabilitiesA" ( _
ByVal lpsDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
lpOutput As Any, _
ByVal dev As Long _
) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const DC_PAPERS As Long = 2
Private Const DC_PAPERSIZE As Long = 3
Private Const CCHFORMNAME As Long = 32 ' Pufferlänge-Konstante
Private Const CCHDEVICENAME As Long = 32 ' Pufferlänge-Konstante
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 Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Sub InfosAuslesen()
Dim VarSettings As Variant
Dim strPrinter As String
On Error Resume Next
strPrinter = Application.ActivePrinter
' strPrinter = "\\Terminator76-pc\HP Officejet 5600 series auf FILE:"
VarSettings = GetPaperSize(strPrinter)
MsgBox "Papierabmessungen" & vbCrLf & _
"X=" & VarSettings(1) & vbCrLf & "Y=" & VarSettings(2) _
, , strPrinter
End Sub
Private Function GetPaperSize( _
ByVal strPrinter As String _
) As Variant
Dim udtDevMode As DEVMODE
Dim audtTemp() As POINTAPI
Dim alngSize(1 To 2) As Long
Dim aintTemp() As Integer
Dim arrBuffer() As Long
Dim lngPrinter As Long
Dim lngLänge As Long
Dim lngPtrDevMode As Long
Dim lngID As Long
Dim lngIndex As Long
Dim lngCount As Long
Dim lngRet As Long
Dim i As Long
On Error Resume Next
' Port entfernen, funzt wahrscheinlich nur in DE
strPrinter = Split(strPrinter, " auf ")(0)
' Printer ohne PRINTER_DEFAULTS-Struktur öffnen. Dazu wurde die
' Deklaration der API-Funktion geändert.
lngRet = OpenPrinter(strPrinter, lngPrinter, ByVal 0)
If lngRet = 0 Then MsgBox "Kein gültiger Drucker": Exit Function
' 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)
' DEVMODE-Struktur füllen
CopyMemory udtDevMode, ByVal lngPtrDevMode, Len(udtDevMode)
' PaperSize-ID auslesen
lngID = udtDevMode.dmPaperSize
' Anzahl verfügbarer Papier-IDs auslesen
lngCount = DeviceCapabilities(strPrinter, ByVal vbNullString, _
DC_PAPERS, ByVal 0, 0)
If lngCount < 1 Then Exit Function
' Puffer für verfügbare PaperSize-IDs bereitstellen
ReDim aintTemp(1 To lngCount)
' PaperSize-IDs im Array speichern
lngRet = DeviceCapabilities(strPrinter, ByVal vbNullString, _
DC_PAPERS, aintTemp(1), 0)
For i = 1 To lngCount
If lngID = aintTemp(i) Then lngIndex = i: Exit For
Next
' Puffer für verfügbare Papierabmessungen anlegen
ReDim audtTemp(1 To lngCount)
' Verfügbare Papierabmessungen auslesen
lngRet = DeviceCapabilities(strPrinter, ByVal vbNullString, _
DC_PAPERSIZE, audtTemp(1), 0)
' Abmessungen aktuelles Papier zurückgeben
alngSize(1) = audtTemp(lngIndex).X
alngSize(2) = audtTemp(lngIndex).Y
GetPaperSize = alngSize
End Function
Ich wollte den PaperSize-Wert erst über WMI auslesen, das hätte mir einiges
an Arbeit erspart, seltsamerweise zickt das aber ab und zu rum.
Ich habe mittlerweile auch herausgefunden, warum bei einigen
Netzwerkdruckern die API OpenPrinter nicht funktioniert hatte. Ich hatte in
der PRINTER_DEFAULTS-Struktur das Element DesiredAccess auf
PRINTER_ALL_ACCESS gesetzt, aber nicht die notwendigen Rechte am Drucker.
Man könnte nun das Zugriffsrecht PRINTER_ACCESS_USE verwenden, aber die
Dokumentation zu OpenPrinter sagt auch:
Points to a PRINTER_DEFAULTS structure. This value can be NULL.
Deshalb habe ich kurzerhand die Deklaration geändert und Null übergeben.
Kannst es ja mal probieren
Andreas Killer
wrote:
> Kannst es ja mal probieren
Hab ich gemacht, funktioniert perfekt. Vielen Dank.
Andreas.
Michael Schwimmer
Hallo Andreas,
freut mich.
Danke für die Rückmeldung!