Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

mehrere Bilder in bestimmter Reihenfolge einfügen

mehrere Bilder in bestimmter Reihenfolge einfügen
23.06.2017 08:22:58
Joline
Guten Morgen ihr Wissenden,
ich schlage mich seit einigen Tagen mit einer fiesen kleinen Problemstellung rum. Ich möchte via Command-Button Bilder einfügen und diese nicht in der Reihenfolge der Dateinamen anordnen (da mehrere Leute das Auswertesystem nutzen ist jede Änderung der Dateinamen eine zusätzliche Fehlerquelle, die ich vermeiden möchte). Ich habe es über mehrere Wege versucht die Bilder über das Makro1 (recte) einzufügen und über ein Makro2 (kursiv) umzusortieren. Im einzelnen Funktionieren beide Makros auch problemlos, aber leider nicht zusammen.
Mein erster Ansatz war über die Call Funktion das 2 Makro aufzurufen, das Makro 1 (gespeichert auf Tabellenblatt) lief problemlos durch, das Makro2 (gespeichert im Modul) aber nicht, das selbe gilt für die Application. Run Variante (Ansatz 2).
Mein dritter Ansatz ist nun das Makro 2 direkt ins Makro 1 zu schreiben (Makro 3). Makro 3 läuft auch vollständig durch, aber leider werden die ausgeschnittenen Bilder nicht auf dem im Code benannte Tabellenblatt eingefügt, sondern auf dem Tabellenblatt auf dem der Command-Button liegt und auf dem auch das Makro 3 geschrieben ist, die Ablagezelle stimmt aber wieder.
Hier für euch mein Code, möglicherweise hat einer von euch eine Idee, woran es liegen könnte. Oder einen ganz anderen Ansatz, ich bin mittlerweile etwas Ratlos...
Das Tabellenblatt was am Ende angezeigt werden soll wird leider auch nicht aufgerufen, ist aber weniger schlimm als mein Bildchaos.
Makro 3:

Private Sub CommandButton3_Click()
Dim bildQuelle As Variant
Dim limit As Integer
Dim hoehe As Integer
Dim hoeheReihe As Integer
Dim abstand As Integer
Dim abstandRand As Integer
Dim abstandBilder As Integer
Dim bildBreite As Integer
Dim bildHoehe As Integer
Application.ScreenUpdating = False
bildBreite = Worksheets("Einstellungen").Range("E2").Value
bildHoehe = Worksheets("Einstellungen").Range("E3").Value
hoeheReihe = Worksheets("Einstellungen").Range("E7").Value
abstandRand = Worksheets("Einstellungen").Range("E5").Value
abstandBilder = Worksheets("Einstellungen").Range("E9").Value + bildBreite
bildQuelle = Application.GetOpenFilename(Title:="Bitte zwei Bilder auswählen:", FileFilter:= _
_
_
"Bilder,*.jpg", MultiSelect:=True)
'MsgBox bildQuelle(1)
If TypeName(bildQuelle) = "Boolean" Then
GoTo Fehler1
End If
If UBound(bildQuelle) > 2 Then
limit = 2
MsgBox "Es wurden mehr als 2 Datein ausgewählt"
Else
limit = UBound(bildQuelle)
End If
Worksheets("Einstellungen").Activate
abstand = abstandRand
hoehe = hoeheReihe
Dim index As Integer
For index = 1 To limit
ActiveSheet.Shapes.AddPicture _
bildQuelle(index), True, True, abstand, hoehe, bildBreite, bildHoehe
abstand = abstand + abstandBilder
Next index
'Call Modul1.ImportBild
    If MsgBox("Bilder in richtige Reigenfolge sortieren?", vbOKOnly, "Bilder einfügen") =  _
vbOK Then
Dim Bild1 As Variant
Dim Bild2 As Variant
For Each Bild1 In Sheets("Einstellungen").Shapes
If Not Intersect(Sheets("Einstellungen").Range("D70:F70"), Bild1.TopLeftCell) Is  _
Nothing Then
Bild1.Copy
Worksheets("ErgebnisZusammen (zum Drucken)").Paste Range("B25")
End If
Next
For Each Bild2 In Sheets("Einstellungen").Shapes
If Not Intersect(Sheets("Einstellungen").Range("A70:C70"), Bild2.TopLeftCell) Is  _
Nothing Then
Bild2.Copy
Worksheets("ErgebnisZusammen (zum Drucken)").Paste Range("L25")
End If
Next
Else
End If
'Application.Run index:=ImportBild
'Workbooks.Open Filename:="S:\KV\Kv1\Prüfprogramme\Werksprüfungen\KV_WP05_Spritzgebäck\vorü  _
_
_
bergehende Hauptvorlage Spritzgebäck_2 Ebenen.xlsm"
'Application.Run "vorübergehende Hauptvorlage Spritzgebäck_2 Ebenen.xlsm!ImportBild"
Exit Sub
Fehler1:
MsgBox "Einfügen abgebrochen!"
Application.ScreenUpdating = True
Worksheets("ErgebnisZusammen (zum Drucken)").Activate
End Sub

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: mehrere Bilder in bestimmter Reihenfolge einfügen
23.06.2017 13:22:50
fcs
Hallo Joline,
ich hab dein Makro mal angepasst.
Die gewählten Bilder werden beim Einfügen einem Datenarray vom Type Shape zugewiesen.
Über dieses Datenarray kann man die Bilder in einer Schleife direkt ansprechen und kopieren und auf dem 2. Blatt in den gewünschten Zellen einfügen.
LG
Franz
Private Sub CommandButton3_Click()
Dim bildQuelle As Variant
Dim limit As Integer
Dim index As Integer
Dim hoehe As Integer
Dim hoeheReihe As Integer
Dim abstand As Integer
Dim abstandRand As Integer
Dim abstandBilder As Integer
Dim bildBreite As Integer
Dim bildHoehe As Integer
Dim arrShape() As Shape
Application.ScreenUpdating = False
bildBreite = Worksheets("Einstellungen").Range("E2").Value
bildHoehe = Worksheets("Einstellungen").Range("E3").Value
hoeheReihe = Worksheets("Einstellungen").Range("E7").Value
abstandRand = Worksheets("Einstellungen").Range("E5").Value
abstandBilder = Worksheets("Einstellungen").Range("E9").Value + bildBreite
bildQuelle = Application.GetOpenFilename(Title:="Bitte zwei Bilder auswählen:", _
FileFilter:="Bilder,*.jpg", MultiSelect:=True)
'MsgBox bildQuelle(1)
If TypeName(bildQuelle) = "Boolean" Then
GoTo Fehler1
End If
If UBound(bildQuelle) > 2 Then
limit = 2
MsgBox "Es wurden mehr als 2 Datein ausgewählt"
Else
limit = UBound(bildQuelle)
End If
Worksheets("Einstellungen").Activate
abstand = abstandRand
hoehe = hoeheReihe
ReDim arrShape(1 To limit)
For index = 1 To limit
Set arrShape(index) = ActiveSheet.Shapes.AddPicture _
(bildQuelle(index), True, True, abstand, hoehe, bildBreite, bildHoehe)
abstand = abstand + abstandBilder
Next index
If MsgBox("Bilder in richtige Reihenfolge sortieren?", _
vbOKOnly, "Bilder einfügen") = vbOK Then
With Worksheets("ErgebnisZusammen (zum Drucken)")
.Activate
For index = 1 To limit
arrShape(index).Copy
Select Case index
Case 1:   .Paste .Range("L25")
Case 2:   .Paste .Range("B25")
End Select
Next
End With
Else
End If
Application.ScreenUpdating = True
Exit Sub
Fehler1:
Application.ScreenUpdating = True
MsgBox "Einfügen abgebrochen!"
End Sub

Anzeige
AW: mehrere Bilder in bestimmter R...
26.06.2017 07:25:05
Joline
Guten Morgen Franz,
vielen Dank für das Anpassen! Es läuft jetzt super!!
Viele Grüße
Joline

346 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige