AW: Ausdruck.AddShape / Zellpositionsbezug
13.10.2003 15:45:55
ANdreas
Hallo Guido,
hier noch mal ein etwas kommentiertes Beispiel, auch übersichtlicher weil ohne Select ;)
Sub Beispiel()
Dim sh As Shape
Dim i%, j%, iSum%, jSum%
i = ActiveCell.Width: j = ActiveCell.Height
iSum = 0: jSum = 0
'Doppelt so groß wie aktive Zelle
Set sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 2 * i, 2 * j)
With sh
.Fill.Solid
.Fill.Transparency = 0.5
.Fill.ForeColor.SchemeColor = 44
.TextFrame.Characters.Text = "Hier der Text"
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.Characters.Font.Bold = True
'Hier erfolgt Berechnung der Position
'Kumulieren der Spaltenbreiten/Zeilenhoehen bis einschl.
'der aktiven Zelle
For i = 1 To ActiveCell.Column
iSum = iSum + Columns(i).Width
Next i
For j = 1 To ActiveCell.Row
jSum = jSum + Rows(j).Height
Next j
'Setzen der berechneten Position
.Left = iSum
.Top = jSum
Application.Wait Now + TimeValue("00:00:02") 'kurz warten
'weitere Verschiebung
.Left = .Left - ActiveCell.Width
.Top = .Top - ActiveCell.Height
MsgBox "weiter"
End With
End Sub
Hierbei wird ein neues Rechteck eingefügt (mit fettem, zentriertem Text, und Farbänderung).
Danach werden die Spaltenbreiten bzw. Zeilenhöhen aller Spalten/Zeilen aufsummiert, die sich über/vor einschließlich der aktiven Zelle befinden. Das Rechteck wird dann an diese Position verschoben. Es befindet sich also rechts unter der aktiven Zelle.
Die zweite Verschiebung sollte das Rechteck genau über die Zelle verschieben.
Hoffe das hilft weiter,
Gruß
Andreas