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.
Visual Basic Code
Sub ResimEkle(yol AsString, sol AsDouble, topp AsDouble, gen AsDouble, yuk AsDouble, ad AsString)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
EndWith
obj.Name = ad
Set obj =NothingEndSub
Visual Basic Code
Sub resimSil(sayfaAd As Worksheet)Dim obj As OLEObject
OnErrorResumeNextForEach obj In sayfaAd.OLEObjects
IfTypeOf obj.ObjectIs MSForms.Image Then
obj.Delete
EndIfNextOnErrorGoTo0Set obj =NothingEndSub
Visual Basic Code
Sub resim()Dim fso AsObjectOnErrorResumeNextWith ThisWorkbook.Sheets(Sayfa2.Name)
resimSil ThisWorkbook.Sheets(.Name)
say =21Set fso = CreateObject("Scripting.FileSystemObject")ForEach 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 +1EndIfNextEndWithOnErrorGoTo0Set fso =NothingEndSub
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 AsStringDim imgLeft AsDoubleDim imgTop AsDoubleDim imgWidth AsDoubleDim imgHeight AsDouble
imgWidth =229.3116
imgHeight =223.9287
ekleLeft =15
ekleTop =16.071418762207Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")
fPath = ThisWorkbook.Path & "\Resimler 2021\"
fName = Dir(fPath & "*.*") 'dosya ismi listesi
'ilk hücre "J21"
'.Offset (RowOffset, ColumnOffset)
x =0With ws.Range("J21")DoWhile Len(fName)>0
imagePath = fPath & fName
ws.Shapes.AddPicture _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=.Offset(Fix(x / 2), x Mod2).Left + ekleLeft, _
Top:=.Offset(Fix(x / 2), x Mod2).Top + ekleTop, _
Width:=imgWidth, _
Height:=imgHeight
x = x +1
fName = Dir 'sonrak dosya adını al
LoopEndWithEndSub
tüm şekilleri silme kodu
Visual Basic Code
Sub ShpSil()Dim shp As Shape
Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")ForEach shp In ws.Shapes
shp.Delete
Next shp
EndSub
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ış)
Cevapla
Son Düzenleme: 20/03/2021, 12:14, Düzenleyen: berduş.