duhudu
Goto Top

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. face-wink
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

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

eisbein
eisbein 11.03.2015 aktualisiert um 06:40:04 Uhr
Goto Top
Guten Morgen!

Ich habe zwar schon gefunden, dass ich AddPicture verwenden muss

Da gibt es doch auch Beispiele bei Tante Google!
Warum steht im Code dann noch ActiveSheet.Pictures.Insert und woher sollen wir die Fehlermeldungen kennen?

Gruß
Eisbein
colinardo
Lösung colinardo 11.03.2015, aktualisiert am 31.01.2024 um 11:12:48 Uhr
Goto Top
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.

screenshot

screenshot

Weiter unten findest du auch noch das Projekt als Demo-File zum Download.

Viel Spaß...

back-to-topBilder 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
Demo-Package

Grüße Uwe
colinardo
colinardo 17.03.2015 aktualisiert um 17:32:14 Uhr
Goto Top
Kommt hier noch Rückmeldung ?? Wenn nicht, den Beitrag bitte noch auf gelöst setzen. Merci.
duhudu
duhudu 19.03.2015 um 11:57:05 Uhr
Goto Top
Hallo colinardo,

vielen Dank für den Code, es hat wunderbar funktioniert. Sorry, dass ich mich jetzt erst melde, aber ich war einige Tage unterwegs.

Viele Grüße,

duhudu