AccessTr.neT

Tam Versiyon: Excel sayfasına kodla resim ekleme
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Sayfalar: 1 2 3
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 Img-cray
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ı Img-grin
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ış)
Sayfalar: 1 2 3