Bild aus variablen Ordner suchen und ein

Hallo zusammen,
bräuchte bitte eure Hilfe meinen Code zu vervollständigen.
Sachstand: Auszug aus meinem Code
Ich drücke auf ein Button und dann soll er mir das Bild aus dem Ordner laut StrPfad finden und einfügen bzw. wenn keines vorhanden ist dann eine MSGBox öffnen, dies mitteilen und dann abrechen.
Fehler: Es kommt immer die MSGBox mit Kein Titelbild gefunden!
Dim strPath As String
Dim strPfad As String
Dim StrFile As String
Dim strBild As String
Dim rngZiel As Range
strPath = "Y:\01\101\" ' wo sich die Ordner befinden
strPfad = Worksheets("01").Range("C1").Value ' befindet sich der Ordnername
StrFile = strPath & strPfad & "\"
strBild = Dir(StrFile & "Titelbild" & "*.ipg") ' Der Bildname ist immer Titelbild, egal in welchen Ordner
If Dir(strBild, vbNormal) = "" Then
MsgBox "Kein Titelbild vorhanden!"
Exit Sub
Else
Set rngZiel = Range("D11").MergeArea ' Die Zelle wo das Bild eingefügt wird
Application.ScreenUpdating = False
With ActiveSheet.Pictures.Insert(StrFile & strBild).ShapeRange
.LockAspectRatio = msoTrue
.Top = rngZiel.Top
.Left = rngZiel.Left
.Height = Application.CentimetersToPoints(9)
.Width = Application.CentimetersToPoints(12.25)
End With
Application.ScreenUpdating = True
End If
Versuche mich jetzt schon zwei Tage daran und finde die Lösung nicht.
Wäre um Lösungsansätze oder Hilfe froh!
Danke

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim strPath As String Dim strPfad As String Dim StrFile As String Dim strBild As String Dim rngZiel As Range strPath = "Y:\01\101\" ' wo sich die Ordner befinden strPfad = Worksheets("01").Range("C1").Value ' befindet sich der Ordnername StrFile = strPath & strPfad & "\" strBild = StrFile & "Titelbild" & "*.jpg" ' Der Bildname ist immer Titelbild, egal in welchen Ordner If Dir(strBild, vbNormal) = "" Then MsgBox "Kein Titelbild vorhanden!" Exit Sub Else Set rngZiel = Range("D11").MergeArea ' Die Zelle wo das Bild eingefügt wird Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(StrFile & strBild).ShapeRange .LockAspectRatio = msoTrue .Top = rngZiel.Top .Left = rngZiel.Left .Height = Application.CentimetersToPoints(9) .Width = Application.CentimetersToPoints(12.25) End With Application.ScreenUpdating = True End If

Dim strPath As String Dim strPfad As String Dim StrFile As String Dim strBild As String Dim rngZiel As Range strPath = "Y:\01\101\" ' wo sich die Ordner befinden strPfad = Worksheets("01").Range("C1").Value ' befindet sich der Ordnername StrFile = strPath & strPfad & "\" strBild = StrFile & "Titelbild" & "*.jpg" ' Der Bildname ist immer Titelbild, egal in welchen Ordner If Dir(strBild, vbNormal) = "" Then MsgBox "Kein Titelbild vorhanden!" Exit Sub Else Set rngZiel = Range("D11").MergeArea ' Die Zelle wo das Bild eingefügt wird Application.ScreenUpdating = False With ActiveSheet.Shapes.AddPicture(Filename:=StrFile & strBild, LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, Left:=rngZiel.Left, Top:=rngZiel.Top, Width:=-1, Height:=-1) .LockAspectRatio = msoTrue .Height = Application.CentimetersToPoints(9) .Width = Application.CentimetersToPoints(12.25) End With Application.ScreenUpdating = True End If

Dim strPath As String Dim strFile As String Dim rngZiel As Range strPath = "Y:\01\101\" ' wo sich die Ordner befinden strPath = strPath & Worksheets("01").Range("C1").Value & "\" ' befindet sich der Ordnername strFile = Dir$(strPath & "Titelbild" & "*.jpg", vbNormal) If strFile = "" Then MsgBox "Kein Titelbild vorhanden!" Exit Sub Else Set rngZiel = Range("D11").MergeArea ' Die Zelle wo das Bild eingefügt wird Application.ScreenUpdating = False With ActiveSheet.Shapes.AddPicture(Filename:=strPath & strFile, LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, Left:=rngZiel.Left, Top:=rngZiel.Top, Width:=-1, Height:=-1) .LockAspectRatio = msoTrue .Height = Application.CentimetersToPoints(9) .Width = Application.CentimetersToPoints(12.25) End With Application.ScreenUpdating = True End If

Ja das mit dem Bild herholen klappt! Super.
Die Größe des Bildes wird im Code vergeben. Das funktioniert jetzt nicht mehr.
.Height = Application.CentimetersToPoints(9)
.Width = Application.CentimetersToPoints(12.25)
Was jetzt leider auch nicht mehr funktioniert ist dass das vorhandene Titelbild nicht mehr gelöscht wird.
Mein Ziel ist es am Deckblatt immer ein Titelbild mit zusenden. Dafür habe ich ein vorgefertigtes Bild (über andere Schaltfläche = der Code funktioniert auch)
und ein projektbezogenes Titelbild sofern vorhanden.
Dim oShape As Shape
For Each oShape In ActiveSheet.Shapes
If Not Intersect(oShape.TopLeftCell, Range("D11")) Is Nothing Then
oShape.Delete
End If
Next
Dim strPath As String
Dim strFile As String
Dim rngZiel As Range
strPath = "Y:\01\101\" ' wo sich die Ordner befinden
strPath = strPath & Worksheets("01").Range("C1").Value & "\" ' befindet sich der Ordnername
strFile = Dir$(strPath & "Titelbild" & "*.jpg", vbNormal)
If strFile = "" Then
MsgBox "Kein Titelbild vorhanden!"
Exit Sub
Else
Set rngZiel = Range("D11").MergeArea ' Die Zelle wo das Bild eingefügt wird
Application.ScreenUpdating = False
With ActiveSheet.Shapes.AddPicture(Filename:=strPath & strFile, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=rngZiel.Left, Top:=rngZiel.Top, Width:=-1, Height:=-1)
.LockAspectRatio = msoTrue
.Height = Application.CentimetersToPoints(9)
.Width = Application.CentimetersToPoints(12.25)
End With
Application.ScreenUpdating = True
End If
Könntest du / ihr mir vielleicht nochmal helfen?

Beliebteste Forumthreads (12 Monate)

Bild aus variablen Ordner suchen und ein

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

246 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild aus variablen Ordner suchen und ein

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

246 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread