3000 Produktbilder automatisch erstellen
16.10.2018 09:21:31
Simon
ich bin neu hier und freue mich, falls mir bei meinem Prodblem geholfen werden kann. Ich habe ein kleines Programm gebaut, dass leider extrem langsam wird.
Es gibt von einem Produkt ca. 3000 Varianten. Ich habe eine vba Schleife programmiert, welche mir von jeder Variante ein Bild erstellt und abspeichert.
Dazu verwende ich eine Tabellenspalte, in der ein Produktschlüssel alle 3000 Varianten eindeutig beschreibt.
Das Bild setzt sich dabei aus 9 verschiedenen Einzelbildern zusammen. Je nach Produktschlüssel wählt das vba Programm aus einem Ordner mit Grundbildern die passenden 9 Einzelbilder und positioniert sie an der korrekten Stelle. Anschließend wird das Bild als gif in einem Odner abgespeichert.
folgende Schritte passieren im Code (zusammegefasst):
For-Schleife:
- 9 Bilder laden und an definiertem Ort platzieren
- Sub BereichSelekt: alle Bilder selektieren
- selektiertes Bild exportieren
10 Bilder exportieren geht ziemlich zügig (15 Sekunden). 100 Bilder dauern schon einige Minuten. Ich habe mal über 1 Tag + 2 Nächte laufen lassen in denen nur 1200 Bilder erstellt wurden.
Sprich, umso mehr Zeilen die For Schleife durchläuft, desto länger dauert ein einzelner Bildexport.
Woran könnte das liegen?
Ich habe bisher probiert zu beschleunigen mit:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For Schleife
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Hatte nicht den gewünschten Effekt.
Ich muss dazu sagen, dass ich die einzelnden Komponenten des Codes zusammengegoogelt und auf mein Problem angepasst habe (Try&Error). Der Code ist daher wahrscheinlich sehr dilettantisch und auch unübersichtlich.
Ich freue mich über Lösungsansätze oder Ideen und danke schon mal im Vorraus
Grüße
Simon
Option Explicit
'Bilder setzen sich aus mehreren als jpg vorliegenden Dateien zusammen. Als erstes werden die _
einzelnen Bilder geladen
Sub Bilder_Laden()
Dim Grundkoerper_Wert As String
Dim Grundkoerper As String
Dim Pfad As String
Dim targetRange As Range
Dim pictureShape As Shape
Dim Dosier1_Wert As String
Dim Dosier1 As String
Dim i As Integer
'jedes i entspricht einem Bild für eine bestimmte Variante. Lässt man mehrere tausend Bilder _
auf einmal durchlaufen, dauert das Speichern der Bilder sehr lange.
'Dann wird empfohlen das Programm mehrmals zu starten und vorher Laufvariable i immer _
anzupassen. z.B. in 100er oder 200er Schritten (For i = 5 To 205 ... etc.)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For i = 304 To 304
Range("AO1") = i
'Bild 1 Grundkörper laden
'Hier die Spalte wählen, die zum erstellen der Bilder durchlaufen werden soll
Grundkoerper_Wert = Range("W" & i)
Grundkoerper = Mid(Grundkoerper_Wert, 3, 1) & Right(Grundkoerper_Wert, 2) 'Hier wird das _
dritte und die letzten beiden Zeichen im Materialcode gewählt, die das Grundkörperbild definieren
Pfad = "C:\Bilder Montageanweisung\jpgs\5er Körper in Vorrichtung.png"
'Zelle in die Grundkörper geladen wird
Set targetRange = Range("AR2")
'hier muss das Bild von der ausgewählten Zelle aus in seiner Position fein justiert werden ( _
Offset wählen oder targetRange.Left/targetRange.Top für Ecke auswählen)
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
targetRange.Left, _
targetRange.Top, _
1271, _
581)
'Dosierstück 1 laden
'Hier die Spalte wählen, die zum erstellen der Bilder durchlaufen werden soll
'Dosier1_Wert = Range("AK" & i)
'Dosier1 = Mid(Dosier1_Wert, 9, 1)
Dosier1 = Range("X" & i)
Pfad = "C:\Bilder Montageanweisung\jpgs\" & Dosier1 & ".png"
'Zelle in die Grundkörper geladen wird
Set targetRange = Range("AR1")
'hier muss das Bild von der ausgewählten Zelle aus in seiner Position fein justiert werden ( _
Offset wählen oder targetRange.Left/targetRange.Top für Ecke auswählen)
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
985, _
435, _
103, _
69)
'Dosierstück 2 laden
'Dosier1_Wert = Range("AK" & i)
'Dosier1 = Mid(Dosier1_Wert, 10, 1)
Dosier1 = Range("Y" & i)
Pfad = "C:\Bilder Montageanweisung\jpgs\" & Dosier1 & ".png"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1100, _
435, _
103, _
69)
'Dosierstück 3 laden
'Dosier1_Wert = Range("AK" & i)
'Dosier1 = Mid(Dosier1_Wert, 11, 1)
Dosier1 = Range("Z" & i)
Pfad = "C:\Bilder Montageanweisung\jpgs\" & Dosier1 & ".png"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1215, _
435, _
103, _
69)
'Dosierstück 4 laden
'Dosier1_Wert = Range("AK" & i)
'Dosier1 = Mid(Dosier1_Wert, 12, 1)
Dosier1 = Range("AA" & i)
Pfad = "C:\Bilder Montageanweisung\jpgs\" & Dosier1 & ".png"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1330, _
435, _
103, _
69)
'Dosierstück 5 laden
'Dosier1_Wert = Range("AK" & i)
'Dosier1 = Mid(Dosier1_Wert, 13, 1)
Dosier1 = Range("AB" & i)
Pfad = "C:\Bilder Montageanweisung\jpgs\" & Dosier1 & " schräg.png"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1407, _
408, _
123, _
100)
'Dosierstückwerkzeug laden
Pfad = "C:\Bilder Montageanweisung\jpgs\Dosierstückdrücker.png"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1435, _
8, _
395, _
455)
'runden Pfeil laden
Pfad = "C:\Bilder Montageanweisung\jpgs\runder Pfeil.jpg"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1540, _
430, _
68, _
32)
'roten Pfeil laden
Dosier1_Wert = Range("AK" & i)
Dosier1 = Mid(Dosier1_Wert, 13, 1)
Pfad = "C:\Bilder Montageanweisung\jpgs\roter Pfeil.jpg"
Set targetRange = Range("AR1")
Set pictureShape = ActiveSheet.Shapes.AddPicture( _
Pfad, _
False, True, _
1490, _
310, _
48, _
77)
BereichSelekt
'selektiertes Bild exportieren
Dim oDia As Object, oChartArea As Object, oChartPic As Object
Dim iBreite As Single, iHoehe As Single, RetVal As Boolean, oBlatt As Object
Dim oBook As Object
Dim sTempPfad As String
On Error GoTo Fehler
Application.ScreenUpdating = False
Dim oShape As Shape, sName As String
Set oShape = ActiveSheet.Shapes(Selection.Name)
' Der Pfad wohin das Bild gespeichert werden soll.
' Für die gewählte Variante muss die Arbeitsmappe einmal gespeichert worden sein
sTempPfad = "C:\Bilder Montageanweisung\Montageschritt 5 5er Körper v2\" & Cells(i, 37) & ". _
gif" ' Zielpfad anpassen, Dateiname entspricht Materialnummer
Application.Selection.CopyPicture 1, 2
Set oBook = Application.Workbooks.Add
Set oDia = oBook.ActiveSheet.ChartObjects.Add(0, 0, 640, 450)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
Set oChartPic = .Pictures(1)
End With
With oChartPic
.Left = 0
.Top = 0
iBreite = .Width
iHoehe = .Height
End With
With oDia
.Border.LineStyle = xlNone
.Width = iBreite
.Height = iHoehe
End With
RetVal = oChartArea.Export(Filename:=sTempPfad, _
Filtername:="GIF", Interactive:=False)
'Application.SendKeys ("{delete}")
If Not RetVal Then
MsgBox "Bild wurde nicht exportiert", vbExclamation
Else
End If
Aufraeumen:
On Error Resume Next
Set oChartPic = Nothing
Set oChartArea = Nothing
Set oDia = Nothing
oBook.Saved = True
oBook.Close
Set oBook = Nothing
Application.ScreenUpdating = True
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub
Fehler:
MsgBox "Fehler beim Grafikexport, Objekt(Markierung) nicht geeignet", _
vbExclamation
Resume Aufraeumen
End Sub
Sub BereichSelekt()
Range(Cells(1, 44), Cells(2, 45)).Select
Dim shaShape As Shape
Dim lngShape As Long
Dim rng As Range
Set rng = Selection
ReDim arrShapes(0)
For Each shaShape In ActiveSheet.Shapes
If shaShape.Visible Then
If Not Intersect(shaShape.TopLeftCell, rng) Is Nothing Then
ReDim Preserve arrShapes(0 To lngShape)
arrShapes(lngShape) = shaShape.Name
lngShape = lngShape + 1
End If
End If
Next shaShape
If lngShape > 0 Then _
ActiveSheet.Shapes.Range(arrShapes()).Select
ActiveWindow.Selection.ShapeRange.Group.Select
End Sub