Hallo Torsten,
ich habe mal weiter probiert und bin dann auf eine Idee gekommen: warum erst ein Bild machen. Man könnte doch auch einfach alle vorhandenen shapes des Panels nochmal in eine Schleife packen und im Manufacturerpanel einblenden.
Den folgeneden Code habe ich mal erweitert, ich verstehe aber die Schleife nicht.Es werden zwar die richtigen Anzahlen an shapes vom Panel eingefügt, aber alle am gleichen Startpunkt übereinander. Dafür kommen an der richtigen Stelle Ovale (habe ich als Test mal so angegeben)
Wie muss der Code der Schleife verändert werden, das alle shapes des Panels wieder als Schleife eingefügt werden
Sub Manufacturerpanel
'Deklarierung der Variablen die Schleife des Panels im Manufacturerpanels
'=> Schleife in Arbeit
'=> Drehung fehlt noch (muss separat berechnet werden das sich das Panel gedreht darstellt)
Dim objShapeMF As Shape
Dim lngIndex1MF As Long, lngIndex2MF As Long
Dim sngWidthMF As Single, sngHeightMF As Single
Dim sngLeftMF As Single, sngTopMF As Single
Dim sngDistanceMFr As Single
Dim sngDistanceMFc As Single
Dim looprowMF As Single
Dim loopcolumnMF As Single
sngWidthMF = Cells(47, 90).Value
sngHeightMF = Cells(47, 92).Value
sngLeftMF = Cells(47, 86).Value
sngTopMF = Cells(47, 88).Value
sngDistanceMFr = Cells(47, 94).Value
sngDistanceMFc = Cells(47, 97).Value
looprowMF = Cells(47, 95).Value
loopcolumnMF = Cells(47, 98).Value
'Panels in Manufacturerpanel mit Schleife
For lngIndex1MF = 0 To loopcolumnMF
For lngIndex2MF = 0 To looprowMF
Set objShapeMF = ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _
Left:=sngLeftMF + sngWidthMF * lngIndex2MF + sngDistanceMFr * lngIndex2MF, _
Top:=sngTopMF + sngHeightMF * lngIndex1MF + sngDistanceMFc * lngIndex1MF, _
Width:=sngWidthMF, Height:=sngHeightMF)
'Ab hier wird das Panel wiederholt
'Die notwendigen Daten werden aus dem Reiter Panel in den Reiter Manufacturerpanel gespiegelt, _
der Startpunkt des ersten Panels wird dazu neu berechnet
'Deklarierung Variable für shape1/Panel (Panel wird immer _
angezeigt)
Dim Farbe1
Farbe1 = Range("ce10").Interior.Color
Dim Left1
Left1 = Range("ch10")
Dim Top1
Top1 = Range("cj10")
Dim Width1
Width1 = Range("cl10")
Dim Hight1
Hight1 = Range("cn10")
'shape1/Panel
ActiveSheet.Shapes.AddShape(msoShapeRectangle, Left1, Top1, _
Width1, Hight1).Select
Selection.ShapeRange.Name = Range("cc10")
Selection.Name = Range("cc10").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe1
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'Deklarierung Variable für shape2/TabRoute (Danke an Nepumuk, _
Herbers Excel Forum)
Dim objShape2 As Shape
Dim lngIndex1a As Long, lngIndex2a As Long
Dim lngColor2 As Long
Dim sngWidth2 As Single, sngHeight2 As Single
Dim sngLeft2 As Single, sngTop2 As Single
Dim sngDistance2r As Single
Dim sngDistance2c As Single
Dim strName2 As String
Dim looprow2 As Single
Dim loopcolumn2 As Single
lngColor2 = Cells(11, 83).Interior.Color
sngWidth2 = Cells(11, 90).Value
sngHeight2 = Cells(11, 92).Value
sngLeft2 = Cells(11, 86).Value
sngTop2 = Cells(11, 88).Value
sngDistance2r = Cells(11, 94).Value
sngDistance2c = Cells(11, 97).Value
strName2 = Cells(11, 81).Value
looprow2 = Cells(11, 95).Value
loopcolumn2 = Cells(11, 98).Value
'shape2/TabRoute mit Schleife
For lngIndex1a = 0 To loopcolumn2
For lngIndex2a = 0 To looprow2
Set objShape2 = ActiveSheet.Shapes.AddShape(Type:= _
msoShapeRectangle, _
Left:=sngLeft2 + sngWidth2 * lngIndex2a + _
sngDistance2r * lngIndex2a, _
Top:=sngTop2 + sngHeight2 * lngIndex1a + _
sngDistance2c * lngIndex1a, _
Width:=sngWidth2, Height:=sngHeight2)
With objShape2
.Name = strName2
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lngColor2
.Transparency = 0
Call .Solid
End With
'ohne Rahmen
.Line.Visible = msoFalse
End With
Next
Next
'Deklarierung Variable für shape3/PCB (Prinzip wie shape2/ _
TabRoute)
Dim objShape3 As Shape
Dim lngIndex1b As Long, lngIndex2b As Long
Dim lngColor3 As Long
Dim sngWidth3 As Single, sngHeight3 As Single
Dim sngLeft3 As Single, sngTop3 As Single
Dim sngDistance3r As Single
Dim sngDistance3c As Single
Dim strName3 As String
Dim looprow3 As Single
Dim loopcolumn3 As Single
lngColor3 = Cells(12, 83).Interior.Color
sngWidth3 = Cells(12, 90).Value
sngHeight3 = Cells(12, 92).Value
sngLeft3 = Cells(12, 86).Value
sngTop3 = Cells(12, 88).Value
sngDistance3r = Cells(12, 94).Value
sngDistance3c = Cells(12, 97).Value
strName3 = Cells(12, 81).Value
looprow3 = Cells(12, 95).Value
loopcolumn3 = Cells(12, 98).Value
'shape3/PCB mit Schleife
For lngIndex1b = 0 To loopcolumn3
For lngIndex2b = 0 To looprow3
Set objShape3 = ActiveSheet.Shapes.AddShape(Type:= _
msoShapeRectangle, _
Left:=sngLeft3 + sngWidth3 * lngIndex2b + _
sngDistance3r * lngIndex2b, _
Top:=sngTop3 + sngHeight3 * lngIndex1b + _
sngDistance3c * lngIndex1b, _
Width:=sngWidth3, Height:=sngHeight3)
With objShape3
.Name = strName3
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lngColor3
.Transparency = 0
Call .Solid
End With
'ohne Rahmen
.Line.Visible = msoFalse
End With
Next
Next
'Deklarierung Variable für shape5/Panelinfo
Dim Farbe5
Farbe5 = Range("ce14").Interior.Color
Dim Left5
Left5 = Range("ch14")
Dim Top5
Top5 = Range("cj14")
Dim Width5
Width5 = Range("cl14")
Dim Hight5
Hight5 = Range("cn14")
'shape5/Panelinfo
ActiveSheet.Shapes.AddShape(msoShapeRectangle, Left5, Top5, _
Width5, Hight5).Select
Selection.ShapeRange.Name = Range("cc14")
Selection.Name = Range("cc14").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe5
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'Deklarierung Variable für shape4/V-score vertical
Dim objShape4v As Shape
Dim lngIndex14v As Long, lngIndex24v As Long
Dim lngColor4v As Long
Dim sngWidth4v As Single, sngHeight4v As Single
Dim sngLeft4v As Single, sngTop4v As Single
Dim sngDistance4v As Single
Dim strName4v As String
Dim looprow4v As Single
lngColor4v = Cells(13, 83).Interior.Color
sngWidth4v = Cells(13, 90).Value
sngHeight4v = Cells(13, 92).Value
sngLeft4v = Cells(13, 86).Value
sngTop4v = Cells(13, 88).Value
sngDistance4v = Cells(13, 94).Value
strName4v = Cells(13, 81).Value
looprow4v = Cells(13, 95).Value
'shape4/V-score vertical mit Schleife
For lngIndex14v = 0 To 0
For lngIndex24v = 0 To looprow4v
Set objShape4v = ActiveSheet.Shapes.AddShape(Type:= _
msoShapeRectangle, _
Left:=sngLeft4v + sngWidth4v * lngIndex24v + _
sngDistance4v * lngIndex24v, _
Top:=sngTop4v + sngHeight4v * lngIndex14v + _
sngDistance4v * lngIndex14v, _
Width:=sngWidth4v, Height:=sngHeight4v)
With objShape4v
.Name = strName4v
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lngColor4v
.Transparency = 0
Call .Solid
End With
'ohne Rahmen
.Line.Visible = msoFalse
End With
Next
Next
'Deklarierung Variable für shape4/V-score horizontal
Dim objShape4h As Shape
Dim lngIndex14h As Long, lngIndex24h As Long
Dim lngColor4h As Long
Dim sngWidth4h As Single, sngHeight4h As Single
Dim sngLeft4h As Single, sngTop4h As Single
Dim sngDistance4h As Single
Dim strName4h As String
Dim loopcolumn4h As Single
lngColor4h = Cells(15, 83).Interior.Color
sngWidth4h = Cells(15, 90).Value
sngHeight4h = Cells(15, 92).Value
sngLeft4h = Cells(15, 86).Value
sngTop4h = Cells(15, 88).Value
sngDistance4h = Cells(15, 97).Value
strName4h = Cells(15, 81).Value
loopcolumn4h = Cells(15, 98).Value
'shape4/V-score horizontal mit Schleife
For lngIndex14h = 0 To loopcolumn4h
For lngIndex24h = 0 To 0
Set objShape4h = ActiveSheet.Shapes.AddShape(Type:= _
msoShapeRectangle, _
Left:=sngLeft4h + sngWidth4h * lngIndex24h + _
sngDistance4h * lngIndex24h, _
Top:=sngTop4h + sngHeight4h * lngIndex14h + _
sngDistance4h * lngIndex14h, _
Width:=sngWidth4h, Height:=sngHeight4h)
With objShape4h
.Name = strName4h
With .Fill
.Visible = msoTrue
.ForeColor.RGB = lngColor4h
.Transparency = 0
Call .Solid
End With
'ohne Rahmen
.Line.Visible = msoFalse
End With
Next
Next
'Deklarierung Variable für shape9a-d/Toolinghole
Dim Farbe9
Farbe9 = Range("ce21").Interior.Color
Dim Left9a
Left9a = Range("cj21")
Dim Top9a
Top9a = Range("cl21")
Dim Left9b
Left9b = Range("cn21")
Dim Top9b
Top9b = Range("cp21")
Dim Left9c
Left9c = Range("cr21")
Dim Top9c
Top9c = Range("ct21")
Dim Left9d
Left9d = Range("cv21")
Dim Top9d
Top9d = Range("cx21")
Dim diameter9
diameter9 = Range("ch21")
'shape9a/Toolinghole
ActiveSheet.Shapes.AddShape(msoShapeOval, Left9a, Top9a, _
diameter9, diameter9).Select
Selection.ShapeRange.Name = Range("cc21")
Selection.Name = Range("cc21").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe9
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'shape9b/Toolinghole
ActiveSheet.Shapes.AddShape(msoShapeOval, Left9b, Top9b, _
diameter9, diameter9).Select
Selection.ShapeRange.Name = Range("cc21")
Selection.Name = Range("cc21").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe9
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'shape9c/Toolinghole
ActiveSheet.Shapes.AddShape(msoShapeOval, Left9c, Top9c, _
diameter9, diameter9).Select
Selection.ShapeRange.Name = Range("cc21")
Selection.Name = Range("cc21").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe9
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'shape9d/Toolinghole
ActiveSheet.Shapes.AddShape(msoShapeOval, Left9d, Top9d, _
diameter9, diameter9).Select
Selection.ShapeRange.Name = Range("cc21")
Selection.Name = Range("cc21").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe9
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'Deklarierung Variable für shape10a-c/Fiducial
Dim Farbe10
Farbe10 = Range("ce22").Interior.Color
Dim Left10a
Left10a = Range("cj22")
Dim Top10a
Top10a = Range("cl22")
Dim Left10b
Left10b = Range("cn22")
Dim Top10b
Top10b = Range("cp22")
Dim Left10c
Left10c = Range("cr22")
Dim Top10c
Top10c = Range("ct22")
Dim diameter10
diameter10 = Range("ch22")
'shape10a/Fiducial
ActiveSheet.Shapes.AddShape(msoShapeOval, Left10a, Top10a, _
diameter10, diameter10).Select
Selection.ShapeRange.Name = Range("cc22")
Selection.Name = Range("cc22").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe10
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'shape10b/Fiducial
ActiveSheet.Shapes.AddShape(msoShapeOval, Left10b, Top10b, _
diameter10, diameter10).Select
Selection.ShapeRange.Name = Range("cc22")
Selection.Name = Range("cc22").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe10
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
'shape10c/Fiducial
ActiveSheet.Shapes.AddShape(msoShapeOval, Left10c, Top10c, _
diameter10, diameter10).Select
Selection.ShapeRange.Name = Range("cc22")
Selection.Name = Range("cc22").Value
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = Farbe10
.Transparency = 0
.Solid
End With
'ohne Rahmen
Selection.ShapeRange.Line.Visible = msoFalse
Next
Next
End sub
Ich denke hier liegt das Problem in der ersten Zeile, die die Ovale einfügt
Set objShapeMF = ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _
Left:=sngLeftMF + sngWidthMF * lngIndex2MF + sngDistanceMFr * lngIndex2MF, _
Top:=sngTopMF + sngHeightMF * lngIndex1MF + sngDistanceMFc * lngIndex1MF, _
Width:=sngWidthMF, Height:=sngHeightMF)
ansonsten fügt die Schleife ja schon die richtige Anzahl an Panels ein, nur eben alle am selben Fleck
BTW: ich weiß der Code für das Panel ist nicht besonders schön geschrieben :( aber er funktioniert :)
Gruß
Raphael