Skip to main content

AccessTr.neT


Excel sayfasına kodla resim ekleme

Excel sayfasına kodla resim ekleme

Çözüldü #1
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?
.rar Tahkikat Evrak Ekleri Ekleme 2021.rar (Dosya Boyutu: 270,43 KB | İndirme Sayısı: 5)
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#2
deneme amaçlı olarak aşağıdaki kodu kullanabilirsiniz
döngü kurarak diğer resimleri ekleyip isimlendirebilirsiniz
Visual Basic Code
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
Cevapla
#3
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.

Visual Basic Code
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

Visual Basic Code
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

Visual Basic Code
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
Cevapla
#4
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
Visual Basic Code
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
Visual Basic Code
Sub ShpSil()
Dim shp As Shape
Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")
For Each shp In ws.Shapes
  shp.Delete
Next shp
End Sub
Cevapla
#5
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
Cevapla
#6
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ış)
Son Düzenleme: 20/03/2021, 12:14, Düzenleyen: berduş.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da