Füllfarbe eines Vorhandenen Shapes ermitteln
Hallo,
ich habe folgendes Problem. Ich habe in einer Exceldatei verschiedene Shapes mit unterschidlichen Füllfarben. Wie kann ich per VBA den Wert der Füllfarbe eines Shapes ermitteln?
Mit den Texteigenschaften und den Größen und Positionsangaben hat schon geklappt.
Dim ClipAblage As DataObject
Set ClipAblage = New DataObject
X = 2
For Each m_shape In ActiveWorkbook.ActiveSheet.Shapes
If Left(m_shape.Name, 3) = "Ova" Then
Worksheets("CB").Range("BA" + CStr(X)).Value = m_shape.Name
Worksheets("CB").Range("BB" + CStr(X)).Value = m_shape.Top
Worksheets("CB").Range("BC" + CStr(X)).Value = m_shape.Left
Worksheets("CB").Range("BD" + CStr(X)).Value = m_shape.Height
Worksheets("CB").Range("BE" + CStr(X)).Value = m_shape.Width
m_shape.Select
With Selection
Rem Textinhalt
ClipAblage.SetText Selection.Characters.Text
If Selection.Characters.Text <> "" Then
Worksheets("CB").Range("BF" + CStr(X)).Value = Selection.Characters.Text
End If
Rem Schriftgrösse
ClipAblage.SetText Selection.Font.Size
Worksheets("CB").Range("BG" + CStr(X)).Value = Selection.Font.Size
Rem Schriftart
ClipAblage.SetText Selection.Font.Name
Worksheets("CB").Range("BH" + CStr(X)).Value = Selection.Font.Name
Rem Füllfarbe
End With
X = X + 1
End If
Vielen Dank für eure Hilfe im Voraus.
ich habe folgendes Problem. Ich habe in einer Exceldatei verschiedene Shapes mit unterschidlichen Füllfarben. Wie kann ich per VBA den Wert der Füllfarbe eines Shapes ermitteln?
Mit den Texteigenschaften und den Größen und Positionsangaben hat schon geklappt.
Dim ClipAblage As DataObject
Set ClipAblage = New DataObject
X = 2
For Each m_shape In ActiveWorkbook.ActiveSheet.Shapes
If Left(m_shape.Name, 3) = "Ova" Then
Worksheets("CB").Range("BA" + CStr(X)).Value = m_shape.Name
Worksheets("CB").Range("BB" + CStr(X)).Value = m_shape.Top
Worksheets("CB").Range("BC" + CStr(X)).Value = m_shape.Left
Worksheets("CB").Range("BD" + CStr(X)).Value = m_shape.Height
Worksheets("CB").Range("BE" + CStr(X)).Value = m_shape.Width
m_shape.Select
With Selection
Rem Textinhalt
ClipAblage.SetText Selection.Characters.Text
If Selection.Characters.Text <> "" Then
Worksheets("CB").Range("BF" + CStr(X)).Value = Selection.Characters.Text
End If
Rem Schriftgrösse
ClipAblage.SetText Selection.Font.Size
Worksheets("CB").Range("BG" + CStr(X)).Value = Selection.Font.Size
Rem Schriftart
ClipAblage.SetText Selection.Font.Name
Worksheets("CB").Range("BH" + CStr(X)).Value = Selection.Font.Name
Rem Füllfarbe
End With
X = X + 1
End If
Vielen Dank für eure Hilfe im Voraus.
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 156968
Url: https://administrator.de/contentid/156968
Ausgedruckt am: 25.11.2024 um 15:11 Uhr
3 Kommentare
Neuester Kommentar
Hallo aruba1!
In etwa so:
und anstelle von
geht's auch mit
Gruß Dieter
In etwa so:
'....
For Each Shape In ActiveWorkbook.ActiveSheet.Shapes
With Shape.OLEFormat.Object
With .Font
f_Name = .Name 'String
f_Size = .Size 'Double
f_FontStyle = .FontStyle 'String
f_Color = .Color 'Double
f_ColorIndex = .ColorIndex 'Long
f_Bold = .Bold 'True(-1)/False(0)
f_Italic = .Italic 'True(-1)/False(0)
End With
With .Interior
i_Color = .Color 'Double
i_ColorIndex = .ColorIndex 'Double
End With
End With
Next
'....
With Shape.OLEFormat.Object
With Shape.DrawingObject
Gruß Dieter
Hallo aruba1!
Dezimal 16777215 = der Farbwert für Weiß (Hex FFFFFF) und als ColorIndex hast Du den Wert --4105 und der steht für die Konstante XlAutomatic bzw "Keine Füllung"
Gruß Dieter
Zitat von @aruba1:
irgendwie klappt das nicht. Als Ergebnis kommt eine Farbe als Zahl raus, z. B. 16777215.
Was heißt klappt nicht?irgendwie klappt das nicht. Als Ergebnis kommt eine Farbe als Zahl raus, z. B. 16777215.
Dezimal 16777215 = der Farbwert für Weiß (Hex FFFFFF) und als ColorIndex hast Du den Wert --4105 und der steht für die Konstante XlAutomatic bzw "Keine Füllung"
Gruß Dieter