per VBA textbox anpassen an Schriftgrösse

04/04/2009 - 01:06 von Willy Steffen | Report spam
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. 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
 

Lesen sie die antworten

#1 Michael Schwimmer
04/04/2009 - 23:54 | Warnen spam
Hallo Willy,


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

Ähnliche fragen