AW: Probiere es mal...
03.07.2014 18:40:46
fcs
Hallo Claus,
hier Beispiele, wie man Shapes formatieren kann.
Wenn man solche Funktionen öfter mal nutzen möchte oder mehrfach in der gleichen Datei, dann sollte man Subs erstellen, an die die Parameter (Start, Ziel, Farbe, etc) für die Erstellung übergeben werden.
Einen Punkt kann man als gefülltes Oval mit gleicher Höhe und Breite (=Durchmesser) darstellen.
Gruß
Franz
Sub MalenShapes()
With ActiveSheet
'Malen Linie01
Call MalenLinie(rngZelleS:=.Cells(2, 2), rngZelleZ:=.Cells(5, 4), _
strName:="Linie01", lngFarbe:=.Range("A1").Interior.Color)
'MalenPunkt01
Call MalenPunkt(rngZelle:=.Cells(2, 3), Diameter:=10, strName:="Punkt01", _
lngFarbe:=.Range("A1").Interior.Color)
End With
End Sub
Sub LoeschenShapes()
Call ShapeLoeschen("Linie01")
Call ShapeLoeschen("Punkt01")
End Sub
Sub MalenLinie(rngZelleS As Range, rngZelleZ As Range, strName, lngFarbe As Long, _
Optional dblWeight As Double = 2, _
Optional lngBeginArrowheadStyle As Long = 6, _
Optional lngEndArrowheadStyle As Long = 2, _
Optional lngArrowheadLength As Long = 3, _
Optional lngArrowheadWidth As Long = 3)
'Zeichnet eine Linie zwischen den Mittelpunkten zweier Zellen
'rngZelleS = Startzelle für Linie
'rngZelleZ = Zielzelle für Linie
'Arroheadstyles:
'1 = msoArrowheadNone
'2 = msoArrowheadTriangle
'3 = msoArrowheadOpen
'4 = msoArrowheadStealth
'5 = msoArrowheadDiamond
'6 = msoArrowheadOval
'-2 = msoArrowheadStyleMixed
'Arroheadlength:
'1 = msoArrowheadShort
'2 = msoArrowheadLengthMedium
'3 = msoArrowheadLong
'-2 = msoArrowheadLengthMixed
'ArroheadWidth:
'1 = msoArrowheadNarrow
'2 = msoArrowheadWidthMedium
'3 = msoArrowheadWide
'-2 = msoArrowheadWidthMixed
Dim objShape As Shape
Dim lbx, lby, lex, ley, xs, ys, xz, yz
On Error GoTo Fehler
With rngZelleS
lbx = .Left + .Width / 2
lby = .Top + .Height / 2
End With
With rngZelleZ
lex = .Left + .Width / 2
ley = .Top + .Height / 2
End With
Set objShape = ActiveSheet.Shapes.AddLine(lbx, lby, lex, ley)
With objShape
.Name = strName
With .Line
.ForeColor.RGB = lngFarbe
.Weight = dblWeight 'Linienbreite
'Startpunkt Line
.BeginArrowheadStyle = lngBeginArrowheadStyle
.BeginArrowheadLength = lngArrowheadLength
.BeginArrowheadWidth = lngArrowheadWidth
'Endpunkt Linie
.EndArrowheadStyle = lngEndArrowheadStyle
.EndArrowheadLength = lngArrowheadLength
.EndArrowheadWidth = lngArrowheadWidth
End With
End With
Fehler:
With Err
Select Case .Number
Case 0
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Sub MalenPunkt(rngZelle As Range, Diameter, strName As String, lngFarbe As Long)
'Malt Punkt (Kreis) mit Durchmesser mitten in Zelle
Dim objShape As Shape
Dim lbx, lby
On Error GoTo Fehler
With rngZelle
lbx = .Left + .Width / 2 - Diameter / 2
lby = .Top + .Height / 2 - Diameter / 2
End With
Set objShape = ActiveSheet.Shapes.AddShape(msoShapeOval, lbx, lby, Diameter, Diameter)
With objShape
.Name = strName
With .Line
.ForeColor.RGB = lngFarbe
.Weight = 1 'Linienbreite
End With
With .Fill
.ForeColor.RGB = lngFarbe
End With
End With
Fehler:
With Err
Select Case .Number
Case 0
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Sub ShapeLoeschen(strShape As String, Optional objSheet As Object)
On Error GoTo Fehler
If objSheet Is Nothing Then Set objSheet = ActiveSheet
objSheet.Shapes(strShape).Delete
Fehler:
With Err
Select Case .Number
Case 0
Case -2147024809 'Shape mit Name nicht gefunden
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub