AW: Kreisdiagramm
08.11.2013 11:52:12
Bastian
Hallo Eddy,
nachfolgend mal ein Makro, welches den Schnittstreifen zeichnet.
Es werden allerdings, wie in Deiner Skizze, immer nur die 9 Lochungen gezeichnet (auch wenn von der Streifenbreite her mehr Löcher passen würden). Das Ganze lässt sich also noch optimieren.
Du hast noch ein Problem bei der Berechnung von VL1: VL1 darf nicht kleiner als D/2 werden, sonst überschneiden sich die Löcher im Schnittstreifen. Das kannst Du nun schön in der Skizze sehen.
Gruß, Bastian
Option Explicit
Sub Draw_Schnittstreifen()
Dim intStartX As Integer, intStartY As Integer, i As Integer
Dim intScale As Double
Dim D As Double
Dim a As Double
Dim VL1 As Double, VL2 As Double
Dim VLQ2 As Double
Dim B2 As Double
On Error Resume Next
ActiveSheet.Shapes.Range(Array("Schnittstreifen")).Delete
On Error GoTo 0
intStartX = 0
intStartY = 300
intScale = 0.5
With Sheets("Schnittstreifen")
D = .Range("D")
B2 = .Range("B2_")
a = .Range("a")
VL1 = .Range("E15")
VL2 = 2 * VL1
VLQ2 = .Range("E16")
End With
'Platine
ActiveSheet.Shapes.AddShape(msoShapeRectangle, intStartX, intStartY, (2 * VL2 + VL1 + D) * _
intScale, B2 * intScale).Select
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset11
'Obere Reihe
For i = 0 To 2
ActiveSheet.Shapes.AddShape(msoShapeOval, (intStartX + i * VL2) * intScale, intStartY + _
a / 2, D * intScale, D * intScale).Select
Next i
'Mittlere Reihe
For i = 0 To 2
ActiveSheet.Shapes.AddShape(msoShapeOval, (intStartX + VL1 + i * VL2) * intScale, _
intStartY + a / 2 + VLQ2 * intScale, D * intScale, D * intScale).Select
Next i
'Untere Reihe
For i = 0 To 2
ActiveSheet.Shapes.AddShape(msoShapeOval, (intStartX + i * VL2) * intScale, intStartY + _
a / 2 + 2 * VLQ2 * intScale, D * intScale, D * intScale).Select
Next i
Call Gruppieren
End Sub
Sub Gruppieren()
Dim varShape() As Variant
Dim shShape As Shape
Dim shGruppe As Shape
Dim intAnzahl As Integer
For Each shShape In Sheets("Schnittstreifen").Shapes
' Debug.Print shShape.Name & " / " & shShape.Type
If shShape.Type 13 And shShape.Type 8 Then 'Bilder und Button ausschliessen
intAnzahl = intAnzahl + 1
ReDim Preserve varShape(1 To intAnzahl)
varShape(intAnzahl) = shShape.Name
End If
Next shShape
Set shGruppe = ActiveSheet.Shapes.Range(varShape).Group
shGruppe.Name = "Schnittstreifen"
ActiveSheet.Shapes.Range(Array("Schnittstreifen")).Select
Selection.ShapeRange.IncrementLeft 50
End Sub