Bild in Excel einfügen, wenn nicht vorhanden

Sub Bild() Range("G7").Select ActiveSheet.Pictures.Insert( _ "I:\Versuch_Okan\Bilder\" & Cells(1, 1).Value & ".JPG"). _ Select Selection.ShapeRange.Reflection.Type = msoReflectionTypeNone Selection.ShapeRange.Height = 226.7716535433 With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorAccent1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 End With With Selection.ShapeRange.Line .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorText1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = 0 .Transparency = 0 End With With Selection.ShapeRange.Line .Visible = msoTrue .Weight = 3.5 End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo!
Diese Information ist beim gewöhnlichen Einfügen im Bild-Objekt nicht mehr verfügbar. Du müsstest schon beim Einfügen des Bildes den ursprünglichen Dateinamen irgendwo speichern, damit Du dann beim neuerlichen Einfügen dagegen prüfen kannst. Dafür bietet sich bspw. der "Alternative Text" des Bild-Objektes an - in diesen schreibst Du beim Einfügen den Dateinamen, und beim neuerlichen Einfügen wird zunächst geprüft, ob dieser Dateiname bereits in irgendeinem alternativen Text in den Bild-Objekten des Blattes vorkommt; wenn nein, wird eingefügt (und der Dateiname in den alternativen Text geschrieben), wenn ja wird das neue Objekt gelöscht und somit nicht eingefügt. Als kommentierter Code:

Sub a()
Const BILDPFAD$ = "U:\_Vorlagen\bbrz-reha-logo.png"
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet
Dim s As Shape, p As Shape, snames As Object, n$
Application.ScreenUpdating = False
Set snames = CreateObject("Scripting.Dictionary")
With Ws
'Die ursprünglichen Dateinamen werden im
'Alternativen Text des Bild-Objekts abgelegt
'Vor jedem Einfügen der Bild-Datei wie o.a.
'werden alle bestehenden Bild-Objekte im Blatt
'durchlaufen und deren gespeicherte, ursprüngliche
'Dateinamen in einem Dictionary gesammelt
For Each s In .Shapes
If Not snames.exists(s.AlternativeText) Then
snames.Add s.AlternativeText, ""
End If
Next s
'Die o.a. Bild-Datei wird zunächst eingefügt
.Pictures.Insert(BILDPFAD).Select
'Aus dem o.a. Pfad wird der Dateiname ermittelt...
n = Mid(BILDPFAD, InStrRev(BILDPFAD, "\") + 1)
'Wenn dieser Dateiname noch nicht in den alternativen Texten
'der bisherigen Bild-Objekte vorkommt, bleibt das neu eingefügte
'Bild-Objekt erhalten und kann formatiert werden...
If Not snames.exists(n) Then
'Gleichzeitig wird dem Bildobjekt der ursprüngliche Dateiname
'in den alternativen Text geschrieben
.Shapes(.Shapes.Count).AlternativeText = n
'hier folgen Formatierungen des Bild-Objekts
Else:
'Wenn der ursprüngliche Dateiname bereits in den alternativen
'Texten der bestehenden Bild-Objekte im Blatt vorkommt wird
'eine entsprechende Meldung angezeigt, und das neue Bild-Objekt
'gelöscht
MsgBox "Bild [" & n & "] schon vorhanden!"
Selection.Delete
End If
End With
Set Wb = Nothing: Set Ws = Nothing: Set s = Nothing
Set p = Nothing: Set snames = Nothing
End Sub

LG
Michael

Beliebteste Forumthreads (12 Monate)

Bild in Excel einfügen, wenn nicht vorhanden

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

333 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild in Excel einfügen, wenn nicht vorhanden

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

333 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread