Bilder in Exel automatisch einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Matthias,
teste mal:

Option Explicit

Public Sub Inset_Pictures()

    Const FOLDER_PATH As String = "H:\1215\Bilder\" 'Anpassen, Backslash am Ende nicht löschen !!!

    Dim objShape As Shape
    Dim objImageFile As Object, objImageProcess As Object
    Dim objWorksheet As Worksheet
    Dim strImagename As String, strTempFile As String
    Dim lngRow As Long

    Set objWorksheet = Worksheets("Tabelle1") 'Anpassen !!!

    For Each objShape In objWorksheet.Shapes
        If objShape.TopLeftCell.Column = 1 Then Call objShape.Delete
    Next

    Set objImageFile = CreateObject(Class:="WIA.ImageFile")
    Set objImageProcess = CreateObject(Class:="WIA.ImageProcess")

    Call objImageProcess.Filters.Add(FilterID:=objImageProcess.FilterInfos("Scale").FilterID)

    With objImageProcess.Filters(1)
        .Properties("PreserveAspectRatio") = True
        .Properties("MaximumWidth") = 60
        .Properties("MaximumHeight") = 75
    End With

    strTempFile = Environ$("TEMP") & "\Temp.jpg"

    If Dir$(strTempFile) <> vbNullString Then Call Kill(PathName:=strTempFile)

    For lngRow = 2 To Cells(Rows.Count, 2).End(xlUp).Row

        strImagename = "Bild(" & Cells(lngRow, 2).Text & ").jpg"

        If Dir$(FOLDER_PATH & strImagename) = vbNullString Then

            Cells(lngRow, 1).Value = "kein Bild"

        Else

            Call objImageFile.LoadFile(Filename:=FOLDER_PATH & strImagename)

            Set objImageFile = objImageProcess.Apply(Source:=objImageFile)

            Call objImageFile.SaveFile(Filename:=strTempFile)

            Call objWorksheet.Shapes.AddPicture(Filename:=strTempFile, _
                LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                Left:=Cells(lngRow, 1).Left, Top:=Cells(lngRow, 1).Top, Width:=-1, Height:=-1)

            Call Kill(PathName:=strTempFile)

        End If
    Next

    Set objImageFile = Nothing
    Set objImageProcess = Nothing
    Set objWorksheet = Nothing

End Sub

Gruß
Nepumuk

O je - hier habe ich mir ja was vorgenommen / ich habe noch nie mit VBA zu tun gehabt
dank crash-kurs habe ich inzwischen herausgefunden, wo ich was einsetzen und anpassen muß
wenn ich dann ausführen eingebe, bekomme ich die Fehlermeldung :
Laufzeitfehler '9' Index außerhalb des Bereiches
Das ganze sieht so aus:
Option Explicit

Public Sub Inset_Pictures()
Const FOLDER_PATH As String = "C:\Users\webwe\Sammlung Trauerkultur GR\Bilder Herr Jordan  _
November 2013\"
Dim objShape As Shape
Dim objImageFile As Object, objImageProcess As Object
Dim objWorksheet As Worksheet
Dim strImagename As String, strTempFile As String
Dim lngRow As Long
Set objWorksheet = Worksheets("C:\Users\webwe\Sammlung Trauerkultur GR\Sammlung  _
Trauerkultur GR  Stand 10.12.2020")
For Each objShape In objWorksheet.Shapes
If objShape.TopLeftCell.Column = 1 Then Call objShape.Delete
Next
Set objImageFile = CreateObject(Class:="WIA.ImageFile")
Set objImageProcess = CreateObject(Class:="WIA.ImageProcess")
Call objImageProcess.Filters.Add(FilterID:=objImageProcess.FilterInfos("Scale").FilterID)
With objImageProcess.Filters(1)
.Properties("PreserveAspectRatio") = True
.Properties("MaximumWidth") = 60
.Properties("MaximumHeight") = 75
End With
strTempFile = Environ$("TEMP") & "\Temp.jpg"
If Dir$(strTempFile)  vbNullString Then Call Kill(PathName:=strTempFile)
For lngRow = 2 To Cells(Rows.Count, 2).End(xlUp).Row
strImagename = "Bild(" & Cells(lngRow, 2).Text & ").jpg"
If Dir$(FOLDER_PATH & strImagename) = vbNullString Then
Cells(lngRow, 1).Value = "kein Bild"
Else
Call objImageFile.LoadFile(Filename:=FOLDER_PATH & strImagename)
Set objImageFile = objImageProcess.Apply(Source:=objImageFile)
Call objImageFile.SaveFile(Filename:=strTempFile)
Call objWorksheet.Shapes.AddPicture(Filename:=strTempFile, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=Cells(lngRow, 1).Left, Top:=Cells(lngRow, 1).Top, Width:=-1, Height:=-1)
Call Kill(PathName:=strTempFile)
End If
Next
Set objImageFile = Nothing
Set objImageProcess = Nothing
Set objWorksheet = Nothing
End Sub

Wenn ich Debugging klicke, wird die Zeile , die mit Set "objWorksheet" beginnt, gelb markiert.
Was kann ich tun?
Gruß. Matthias

Public Sub Inset_Pictures() Const FOLDER_PATH As String = "C:\Users\webwe\Sammlung Trauerkultur GR\Bilder Herr Jordan _ November 2013\ " Dim objShape As Shape Dim objImageFile As Object, objImageProcess As Object Dim objWorksheet As Worksheet Dim strImagename As String, strTempFile As String Dim lngRow As Long Set objWorksheet = Worksheets("Grundtabelle") For Each objShape In objWorksheet.Shapes If objShape.TopLeftCell.Column = 1 Then Call objShape.Delete Next Set objImageFile = CreateObject(Class:="WIA.ImageFile") Set objImageProcess = CreateObject(Class:="WIA.ImageProcess") Call objImageProcess.Filters.Add(FilterID:=objImageProcess.FilterInfos("Scale").FilterID) With objImageProcess.Filters(1) .Properties("PreserveAspectRatio") = True .Properties("MaximumWidth") = 60 .Properties("MaximumHeight") = 75 End With strTempFile = Environ$("TEMP") & "\Temp.jpg" If Dir$(strTempFile) vbNullString Then Call Kill(PathName:=strTempFile) For lngRow = 2 To Cells(Rows.Count, 2).End(xlUp).Row strImagename = "Bild (" & Cells(lngRow, 2).Text & ").jpg" If Dir$(FOLDER_PATH & strImagename) = vbNullString Then Cells(lngRow, 1).Value = "kein Bild" Else Call objImageFile.LoadFile(Filename:=FOLDER_PATH & strImagename) Set objImageFile = objImageProcess.Apply(Source:=objImageFile) Call objImageFile.SaveFile(Filename:=strTempFile) Call objWorksheet.Shapes.AddPicture(Filename:=strTempFile, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Cells(lngRow, 1).Left, Top:=Cells(lngRow, 1).Top, Width:=-1, Height:=-1) Call Kill(PathName:=strTempFile) End If Next Set objImageFile = Nothing Set objImageProcess = Nothing Set objWorksheet = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Bilder in Exel automatisch einfügen

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder in Exel automatisch einfügen

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread