AccessTr.neT

Tahkikat Evrak Ekleri Ekleme 2021 İsimli klasördeki resim klasöründen Excel dosyası içerisindeki şablona göre resimleri çağırabilir miyiz? Getirebilir miyiz?

deneme amaçlı olarak aşağıdaki kodu kullanabilirsiniz
döngü kurarak diğer resimleri ekleyip isimlendirebilirsiniz

Sub ImageEkle()



Dim ws As Worksheet

Dim imagePath As String

Dim imgLeft As Double

Dim imgTop As Double



Set ws = ActiveSheet

imagePath = "D:\Desktop\Resimler 2021\images (3).jpg"

imgLeft = 3.7 * ws.Shapes("Resim 2").Left ' ActiveCell.Left

imgTop = ws.Shapes("Resim 2").Top  'ActiveCell.Top

imgWidth = ws.Shapes("Resim 2").Width

imgHeight = ws.Shapes("Resim 2").Height

'Width & Height = -1 means keep original size

'ws.Shapes("Resim 2").Delete

Set shp = ws.Shapes.AddPicture( _

    Filename:=imagePath, _

    LinkToFile:=msoFalse, _

    SaveWithDocument:=msoTrue, _

    Left:=imgLeft, _

    Top:=imgTop, _

    Width:=imgWidth, _

    Height:=imgHeight)

 shp.Name = "DenemeResim"

End Sub

Döngü ile yapılmış hali.
Bir modüle ekleyin ve resim olan makra çağrılacak.
Resimler klasördeki resim adları ile alınıyor lakin dosya boyutu 55mb oluyor
Bende anlamadım.Silme koduda silmiyor galiba doğru olmasına rağmen.

Sub ResimEkle(yol As String, sol As Double, topp As Double, gen As Double, yuk As Double, ad As String)

    Dim obj As OLEObject

    Set obj = ThisWorkbook.Sheets(Sayfa2.Name).OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False,        DisplayAsIcon:=False, _

                            Left:=sol, _

                            Top:=topp, _

                            Width:=gen, _

                            Height:=yuk)

    

    With obj.Object

        .Picture = LoadPicture(yol)

        .PictureSizeMode = fmPictureSizeModeStretch

    End With

    obj.Name = ad

    Set obj = Nothing

End Sub

Sub resimSil(sayfaAd As Worksheet)

    Dim obj As OLEObject

    On Error Resume Next

    For Each obj In sayfaAd.OLEObjects

        If TypeOf obj.Object Is MSForms.Image Then

            obj.Delete

        End If

    Next

     On Error GoTo 0

     Set obj = Nothing

End Sub

Sub resim()

    Dim fso As Object

    On Error Resume Next

    With ThisWorkbook.Sheets(Sayfa2.Name)

        resimSil ThisWorkbook.Sheets(.Name)

        say = 21

        Set fso = CreateObject("Scripting.FileSystemObject")

        For Each file In fso.GetFolder(ThisWorkbook.Path & "\Resimler 2021").Files

            If LCase(fso.GetExtensionName(file)) <> "xlsm" Then

                ResimEkle ThisWorkbook.Path & "\Resimler 2021\" & file.Name, _

                        .Cells(say, "j").Left, .Cells(say, "j").Top, .Cells(say, "j").Width, .Cells(say, "j").Height - 1 _

                       , fso.GetBaseName(file)

                say = say + 1

             End If

        Next

    End With

    On Error GoTo 0

    Set fso = Nothing

End Sub

aşağıdaki yordamlar da denenebilir boyut daha az geldi : 200KB
not: ilk resmin şablon olduğunu düşündüğümden bütün resimleri silip öyle dener misiniz?
Şekil ekleme Kodu

Sub ShpEkle()



Dim ws As Worksheet

Dim imagePath As String

Dim imgLeft As Double

Dim imgTop As Double

Dim imgWidth As Double

Dim imgHeight As Double



imgWidth = 229.3116

imgHeight = 223.9287

ekleLeft = 15

ekleTop = 16.071418762207



Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")

fPath = ThisWorkbook.Path & "\Resimler 2021\"

    fName = Dir(fPath & "*.*")        'dosya ismi listesi

'ilk hücre "J21"

'.Offset (RowOffset, ColumnOffset)

x = 0

With ws.Range("J21")

    Do While Len(fName) > 0

    imagePath = fPath & fName

        ws.Shapes.AddPicture _

                Filename:=imagePath, _

                LinkToFile:=msoFalse, _

                SaveWithDocument:=msoTrue, _

                Left:=.Offset(Fix(x / 2), x Mod 2).Left + ekleLeft, _

                Top:=.Offset(Fix(x / 2), x Mod 2).Top + ekleTop, _

                Width:=imgWidth, _

                Height:=imgHeight

            x = x + 1

            fName = Dir                                      'sonrak dosya adını al

    Loop

End With

End Sub

tüm şekilleri silme kodu

Sub ShpSil()

Dim shp As Shape

Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")

For Each shp In ws.Shapes

  shp.Delete

Next shp

End Sub

Sanıyorum soru dosyada image kullanılmış Halil hocam.
Shapes.AddPicture kullanmışsınız.
Bende onu kullanmıştım sorun olmuyordu lakin image olayınıda hallederseniz arşivleriz dosyayı

excel sizin işiniz hocam)
aslında ne kullanıldığını anlamamıştım 1 tane shape 1 tane de resim ekledim baktım shape daha çok benziyor o nedenle shape kullandım

---

tamam hocam haklısınız ilk dosyayı indirip tekrar kontrol ettim dediğiniz gibi resimmiş))
gerçi isminden zaten belli ama basiretim bağlanmış)