AddShape zeichnet versetzt
29.05.2008 15:19:00
Thomas
habe seit dem Umstieg von Excel2003 zu 2007 Probleme mit Code, der sich unter 2007 anders verhält.
Bis jetzt nahm ich noch an, es liegt an mir, aber jetzt bin ich hier im Archiv fündig geworden.
Unter:
https://www.herber.de/forum/archiv/320to324/t322677.htm#322677
gibt es folgenden Code:
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
Dieser zeichnet ein Rechteck. Nimmt man unter Excel2007 als Beispiel die Zoomstufe 90% und setzt die Zeilenhöhen z.B. der Zeilen 1-20 auf 20 Punkte hoch, wird das Rechteck z.B. in Zelle C15 versetzt gezeichnet.
Könnt Ihr den Fehler nachvollziehen und viel wichtiger: habt ihr eine Idee, dies zu umgehen?
Hier mein ursprünglicher (sehr gekürzter) Code:
Dim r As Range
Set r = ActiveCell 'Oval wird mit durchsichtiger Füllfarbe, schwarz und 0,75 dick über 2 Spalten gezeichnet
With ActiveSheet.Shapes.AddShape(msoShapeOval, r.Left, r.Top, 2 * r.Width, r.Height)
.Fill.Visible = msoFalse
.Line.Weight = 0.75
.Line.ForeColor.RGB = RGB(0, 0, 0)
End With
Über Eure Hilfe würde ich mich sehr freuen!
MfG
TomTau