|
Hallo,
ich habe eine Frage zu meinem VBA Code (siehe code unten), komme selber nicht mehr weiter.
Es geht um die grafische Darstellung von Elementen für eine Spritzgussmaschine. Mit einer Combibox sollen mehrere Elemente aus einer Übersichtsdatei gewählt und so zusammengefügt werden, dass man in einem weiteren Tabellenblatt ein Bild der finalen individuell konfigurierten Schnecke bekommt. Die gewünschten Elemente sollen (zum Beispiel) mit einer Combibox aus einer Liste der verfügbaren Elemente gewählt werden.
- Momentan kann man jedes Element nur einmal wählen: ist es möglich die Bilder/Elemente mehrmals zu wählen? Also z.B
2x Förderelement - 1x Knetblock1 - 1x Förderelement - 2x Knetblock2 - 2x Förderlement etc. - die Reihenfolge der Elemente ist sehr wichtig und müsste wählbar sein.
- in der Tabelle mit allen Informationen ist in Zeile 3 auch die Länge der jeweiligen Elemente gegeben. Kann man neben dem Bildern auch die Längen hinzufügen? Das heißt beim Auswählen vom "Förderelement" wird zusätzlich die länge "30mm" ausgewählt und im gleichen Tabellenblatt, wie die finale Grafik, eingefügt damit man beim zusammenfügen sieht ab wann man die maximal länge erreicht.
danke und viele Grüße
Option Explicit
Dim TopPosBild As Double
Dim LeftPosBild As Double
Public Sub Main()
'Variablen
Dim arr As Variant
Dim objShape As Shape
Dim i As Long, sArrElements As String
ReDim arrElements(0 To 0)
'Bildposition
TopPosBild = Application.Worksheets("Test1").Range("$D$11").Top
LeftPosBild = Application.Worksheets("Test1").Range("$D$11").Left + 10
'Vorhandenes Bild löschen
Application.Worksheets("Test1").Activate
For Each objShape In ActiveSheet.Shapes
If objShape.Top = TopPosBild Then
objShape.Delete
End If
Next
With Worksheets("test1").ListBox1
If .ListIndex = -1 Then Exit Sub
For i = 0 To .ListCount - 1
'** Gewählte Einträge auslesen
If .Selected(i) Then
If .List(i) <> "" Then
sArrElements = sArrElements & IIf(sArrElements = "", .List(i), "," & .List(i))
End If
End If
Next
If Len(sArrElements) = 0 Then Exit Sub
arr = Split(sArrElements, ",")
For i = LBound(arr) To UBound(arr)
Call AddImage(getnames(arr(i)))
Next
End With
Set objShape = Nothing
End Sub
Public Sub AddImage(ByVal strElementgewaehlt As String)
'Variablen
Dim objShape As Shape
Application.ScreenUpdating = False
'Bild in Tabellenblatt "Tabelle" suchen und kopieren
With Worksheets("Tabelle")
.Activate
.Shapes(strElementgewaehlt).Select: Selection.Copy 'statt Grafik 3, das Ergebnis der InputBox
End With
'Bild in Tabellenblatt "Konfiguration" einfügen
With Worksheets("Test1")
.Activate
.Range("$D$11").Select
.Pictures.Paste
'Bilder nebeneinander anordnen
For Each objShape In .Shapes
If objShape.TopLeftCell.Address = "$D$11" Then '$D$11 ist die Zelle in der das Bild landen soll
objShape.Left = LeftPosBild
LeftPosBild = LeftPosBild + objShape.Width 'nächstes Bild rechts davon
End If
Next
End With
Application.ScreenUpdating = True
Set objShape = Nothing
End Sub
Function getnames(ByVal sName As String) As String
'wandelt die Bezeichnung in den Namen um
'sonst wird das element nicht in shapes() gefunden
Dim objShape As Shape
With Worksheets("Tabelle")
For Each objShape In .Shapes
Debug.Print objShape.Name & " : " & sName
If CStr(objShape.TopLeftCell.Offset(-1).Value) = sName Then
getnames = objShape.Name
Exit For
End If
Next
End With
Set objShape = Nothing
End Function
Sub Laeng()
Call Main
End Sub
|