Wie Artikeliste automatisch mit Bildern per Makro befüllen? In Mappe speichern nicht verknüpfen!
Hallo,
ich habe eine Artikelliste in die ich gerne Bilder einfügen möchte (Spalte B). Die Bilder heißen wie die Artikelnummer nur mit ".jpg" am Ende.
Folgendes Makro funktioniert eigentlich ganz gut, allerdings habe ich das Problem, das viele schon hatten, dass die Bilder nur verknüpft werden und die die Bilder daher auf einem anderen Rechner nicht sichtbar sind. Somit für mich unbrauchbar.
Option Explicit
Sub Bilder_einfügen()
Dim Pfad As String, Wiederholungen As Long
On Error Resume Next
Pfad = "D:\Temp\munkees-total\"
For Wiederholungen = 2 To Range("A65536").End(xlUp).Row
Cells(Wiederholungen, 2).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 1) & ".jpg").Select
Next
End Sub
Ich habe zwar schon gefunden, dass ich AddPicture verwenden muss, allerdings mangels Programmierkenntnissen habe ich nur Fehlermeldungen produziert.
Ganz optimal wäre es noch, wenn ich die Bilder automatisch auf die Zellengröße anpassen könnte und dabei Ihr Größenverhältnis gleich bleiben würde, da die Bilder unterscheidliche Seitenverhältnisse haben.
Wie muss ich den Code umschreiben?
Danke und Gruß
duhudu
ich habe eine Artikelliste in die ich gerne Bilder einfügen möchte (Spalte B). Die Bilder heißen wie die Artikelnummer nur mit ".jpg" am Ende.
Folgendes Makro funktioniert eigentlich ganz gut, allerdings habe ich das Problem, das viele schon hatten, dass die Bilder nur verknüpft werden und die die Bilder daher auf einem anderen Rechner nicht sichtbar sind. Somit für mich unbrauchbar.
Option Explicit
Sub Bilder_einfügen()
Dim Pfad As String, Wiederholungen As Long
On Error Resume Next
Pfad = "D:\Temp\munkees-total\"
For Wiederholungen = 2 To Range("A65536").End(xlUp).Row
Cells(Wiederholungen, 2).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 1) & ".jpg").Select
Next
End Sub
Ich habe zwar schon gefunden, dass ich AddPicture verwenden muss, allerdings mangels Programmierkenntnissen habe ich nur Fehlermeldungen produziert.
Ganz optimal wäre es noch, wenn ich die Bilder automatisch auf die Zellengröße anpassen könnte und dabei Ihr Größenverhältnis gleich bleiben würde, da die Bilder unterscheidliche Seitenverhältnisse haben.
Wie muss ich den Code umschreiben?
Danke und Gruß
duhudu
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 265805
Url: https://administrator.de/forum/wie-artikeliste-automatisch-mit-bildern-per-makro-befuellen-in-mappe-speichern-nicht-verknuepfen-265805.html
Ausgedruckt am: 22.12.2024 um 16:12 Uhr
4 Kommentare
Neuester Kommentar
Hallo duhudu, Willkommen auf Administrator.de!
Das gewünscht kannst du mit folgendem Code erreichen. Den Pfad und die Dateierweiterung legst du in den ersten Zeilen fest.
Das Script extrahiert für jedes Bild die Bild-Dimensionen aus den erweiterten Dateieigenschaften und passt das Bild dann an die Größe der Zielzelle an.
Alle weiteren Erläuterungen findest du als Kommentare im Quellcode. In diesem Beispiel werden die Namen der Bilder von A2:A(ende) verarbeitet und die Bilder jeweils in die Spalte B daneben eingefügt. Bitte sorge dafür das die Zellen vorher schon die gewünschte Größe haben. Alles weitere steht in Kommentaren im Quellcode.
Weiter unten findest du auch noch das Projekt als Demo-File zum Download.
Viel Spaß...
Demo-Package
Grüße Uwe
Das gewünscht kannst du mit folgendem Code erreichen. Den Pfad und die Dateierweiterung legst du in den ersten Zeilen fest.
Das Script extrahiert für jedes Bild die Bild-Dimensionen aus den erweiterten Dateieigenschaften und passt das Bild dann an die Größe der Zielzelle an.
Alle weiteren Erläuterungen findest du als Kommentare im Quellcode. In diesem Beispiel werden die Namen der Bilder von A2:A(ende) verarbeitet und die Bilder jeweils in die Spalte B daneben eingefügt. Bitte sorge dafür das die Zellen vorher schon die gewünschte Größe haben. Alles weitere steht in Kommentaren im Quellcode.
Weiter unten findest du auch noch das Projekt als Demo-File zum Download.
Viel Spaß...
Bilder anhand von Bildernamen in Arbeitsmappe integrieren und Größe an Zielzelle anpassen
Sub InsertPicures()
'Variablen
Dim intWidth As Integer, intHeight As Integer, objSize As Object, regex As Object, fso As Object, objShell As Object, file As Object, nsFolder As Object, cell As Range, dblRatio As Double, rngTargetCell As Range, strFilePath As String, intNewWidth As Integer, intNewHeight As Integer, percentHeight As Single, percentWidth As Single, pRatio As Single, intPosHor As Integer, BILDERPFAD as String, IMAGEEXTENSION as String
'Pfad in dem die Bilder liegen
BILDERPFAD = "D:\Temp\munkees-total"
'Dateierweiterung der Bilder
IMAGEEXTENSION = ".jpg"
'Objekte
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Set regex = CreateObject("vbscript.regexp")
'regex settings
regex.Global = True: regex.IgnoreCase = True: regex.MultiLine = False
regex.Pattern = "(\d+).*?(\d+)"
'Namespace Object für Ordner erstellen
Set nsFolder = objShell.Namespace(BILDERPFAD)
'Aktuelles Arbeitsblatt
With ActiveSheet
' Für jede Zell von A2:A(Ende)
For Each cell In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
'vollständiger Pfad des Bildes
strFilePath = BILDERPFAD & "\" & cell.Value & IMAGEEXTENSION
'Zielzelle für das Bild (Zelle gleich neben dem Namen des Bildes)
Set rngTargetCell = cell.Offset(0, 1)
'Wenn das Bild existiert
If fso.FileExists(strFilePath) Then
'Hole eine Referenz zur Datei
Set file = nsFolder.ParseName(cell.Value & IMAGEEXTENSION)
'Lese die Dimension des Bildes aus
Set objSize = regex.Execute(nsFolder.GetDetailsOf(file, 31))
'wenn die Größe extrahiert werden konnte...
If objSize.Count > 0 Then
intWidth = objSize(0).submatches(0) 'Breite des Bildes
intHeight = objSize(0).submatches(1) 'Höhe des Bildes
'Passe die Dimensionen des Bildes an die Zielzelle an
percentHeight = rngTargetCell.Height / intHeight
percentWidth = rngTargetCell.Width / intWidth
pRatio = IIf(percentHeight < percentWidth, percentHeight, percentWidth)
intNewWidth = intWidth * pRatio
intNewHeight = intHeight * pRatio
' Hochformatbilder Horizontal in der Zelle zentrieren
intPosHor = (rngTargetCell.Width - intNewWidth) / 2
'Füge das Bild in die Zelle als embedded Image ein welches mit der Arbeitsmappe gespeichert wird
.Shapes.AddPicture strFilePath, msoFalse, msoTrue, rngTargetCell.Left + intPosHor, rngTargetCell.Top, intNewWidth, intNewHeight
Else
rngTargetCell.Value = "Bildgröße konnte nicht extrahiert werden!"
End If
Else
rngTargetCell.Value = "Bild wurde nicht gefunden!"
End If
Next
End With
Set fso = Nothing
Set objShell = Nothing
Set regex = Nothing
End Sub
Grüße Uwe
Kommt hier noch Rückmeldung ?? Wenn nicht, den Beitrag bitte noch auf gelöst setzen. Merci.