Bilder immer aus dem gleichen Ordner wie Datei

Question

Wie funktioniert dies, wenn die Bilder immer aus dem gleichen Ordner gzogen werden sollen, indem die Datei abgaspeichert ist.

Answer 1

Nochmal etwas genauer.
Bin hier im Forum auf folgendes
"Bilder automatisch in Excel einfügen"
https://supportnet.de/fresh/2005/11/id1193541.asp

Option Explicit

Sub Bilder_einfügen()
Dim Pfad As String, Wiederholungen As Long
On Error Resume Next
Pfad = "C:\"
For Wiederholungen = 2 To Range("A65536").End(xlUp).Row
Cells(Wiederholungen, 3).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 1) & ".jpg").Select
Next
End Sub

Wie kann man den Pfad definieren, damit er immer dem Ordner entspricht idem die Datei abgespeichert ist!


Vielen Dank!

Answer 2

Hallo,

ändere die Zeile

Pfad = "C:\"

in

Pfad = ThisWorkbook.Path & "\"

Gruß

M.O.

Answer 3

Hallo,

habe nun folgendes Makro aus verschiedenen Vorlagen aus dem netz zusammengeschreiben.
Das Marko soll 15 Bilder in bestimmte Zellen einfügen:


Sub Bilder_einfuegen()

Dim Pfad As String, i As Long
Dim PicBild As Picture
Dim arr As Variant



On Error Resume Next

Pfad = ThisWorkbook.Path & "\"
arr = Array("E17", "E18", "E19", "E24", "E25", "E26", "E31", "E32", "E33", "E38", "E39", "E40", "E45", "E46", "E47")
Application.ScreenUpdating = False

For i = LBound(arr) To UBound(arr)
Set PicBild = _
ActiveSheet.Pictures.Insert(Pfad & Range(arr(i)).Value & ".jpg")

PicBild.Top = Range(arr(i)).Top + 5
PicBild.Left = Range(arr(i)).Left + 15
PicBild.Height = 190
PicBild.Width = 190
Next
Application.ScreenUpdating = True

Set PicBild = Nothing


End Sub

-----------------------------------------------------------------------------------
Zur Erklärung:
In den Zellen des Array's stehen zahlen von 1 -15 (entsprechend "E17"=1, "E18"=2, usw. ) . Ebenfalls sind die Bilddateien von 1.jpg bis 15.jpg vorhanden. Ist dies der Fall dann funktioniert das Makro und fügt alle Bilder an die richtige position ein.
Fehlen jedoch Bilddateien gibt es folgende zwei Probleme

1. Fehlt z.B. Bild "2.jpg" wird das Bild "1.jpg" in die Zelle A18 anstatt A17 eingefügt. Die Zelle A17 bleibt frei.

2. Fehlen z.B. Bilder "10.jpg" bis "15.jpg" , so wird das letzte auffindbare Bild (hier 9.jpg) in die Zelle E47 eingefügt welche eigentlich für Bild "15.jpg" vorgesehen ist.

Hoffe mir kann jmd weiterhelfen.

Answer 4

Hallo,

versuch es mal so:

Sub Bilder_einfuegen()

Dim Pfad As String
Dim i As Long
Dim arr As Variant
Dim strDatnam As String

On Error Resume Next

Pfad = ThisWorkbook.Path & "\"
arr = Array("E17", "E18", "E19", "E24", "E25", "E26", "E31", "E32", "E33", "E38", "E39", "E40", "E45", "E46", "E47")
Application.ScreenUpdating = False

For i = LBound(arr) To UBound(arr)

strDatnam = Pfad & Range(arr(i)).Value & ".jpg"

'prüfen, ob überhaupt ein Bild vorhanden ist, falls ja dann einfügen
If Len(Dir(strDatnam)) > 0 Then
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Range(arr(i)).Left + 15, Range(arr(i)).Top + 5, 190, 190
End If

Next

Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 5

Vielen Dank!
Funktioniert !

Answer 6

Nun hätte ich noch ein Anliegen. Das es mir ersparen soll die Bilder umbenennen zu müssen.

Ist es auch möglich wenn die Bilddateien als z.B.

"IMG_0001.jpg"
abgespeicher sind anstatt "1.jpg" in der entsprechenden Zelle steht aber nur der Wert 1 z.B. "E17 =1"

Gibt es da eine Möglichkeit ?

Answer 7

Hallo,

dann ändere die Zeile

strDatnam = Pfad & Range(arr(i)).Value & ".jpg"

wie folgt:

If Len(Range(arr(i)).Value) = 1 Then
strDatnam = Pfad & "IMG_000" & Range(arr(i)).Value & ".jpg"
Else
strDatnam = Pfad & "IMG_00" & Range(arr(i)).Value & ".jpg"
End If

Ich gehe mal davon aus, dass die Zahlen höchstens zweistellig sind.

Gruß

M.O.

Answer 8

Die Zahlen können auch vierstellig werden. Bekommt man dies auch hin oder ist da zu aufwendig?

Vielen Dank für deine ganze Hilfe!

Answer 9

Hallo,

dann mach es wie folgt:

Sub Bilder_einfuegen()

Dim Pfad As String
Dim i As Long
Dim arr As Variant
Dim strDatnam As String

On Error Resume Next

Pfad = ThisWorkbook.Path & "\"
arr = Array("E17", "E18", "E19", "E24", "E25", "E26", "E31", "E32", "E33", "E38", "E39", "E40", "E45", "E46", "E47")
Application.ScreenUpdating = False

For i = LBound(arr) To UBound(arr)

Select Case Len(Range(arr(i)).Value)
Case 1: strDatnam = Pfad & "IMG_000" & Range(arr(i)).Value & ".jpg"
Case 2: strDatnam = Pfad & "IMG_00" & Range(arr(i)).Value & ".jpg"
Case 3: strDatnam = Pfad & "IMG_0" & Range(arr(i)).Value & ".jpg"
Case 4: strDatnam = Pfad & "IMG_" & Range(arr(i)).Value & ".jpg"
End Select

'prüfen, ob überhaupt ein Bild vorhanden ist, falls ja dann einfügen
If Len(Dir(strDatnam)) > 0 Then
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Range(arr(i)).Left + 15, Range(arr(i)).Top + 5, 190, 190
End If

Next

Application.ScreenUpdating = True

End Sub

Gruß

M.O.