Klasörden Çağırılan Resmin Kalıcı Olmasını Sağlamak

[owenefe]

Selamlar herkese,

Excelde bir dosyam var sizin destekleriniz ile makro yazılmıştı. Belli bir hücredeki isim ile aynı isme sahip bilgisayarda belirttiğim klasör içinde bulunan resimleri excele bir buton sayesınde çağırabiliyorum. Herşey süper istediğim hücre içine tam oturuyor vs ama daha sonra o klasörü yada resimleri silince exceldeki resimde siliniyor ve aşağıdaki gibi bir hata veriyor. Halbuki ben çağırdığım resmın içinde kalıcı olmasını istiyorum. Normalde nasıl instertten resim çağırdığımızda o resmi pc den silsek bile dosyada duruyor buda aynı şekilde kalsın ıstıyorum. Çünkü exceli paylaştığım ınsanlar açtığında reismleri göremiyor.. Makroyuda aşağıya ekledim

Sub resim_getir()
Application.ScreenUpdating = False
On Error Resume Next
Dim Resim As Object, i As Long, yol As String, dosya As String
yol = "C:\Users\Metin\Desktop\foto"

Set Alan = Range("B8:P50") 'silinecek resim alan?
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

If Dir(yol & "\" & Cells(28, "B").Value & ".jpg") <> "" Then 'bu alan her resim için de?i?tirilecek
dosya = "\" & Cells(28, "B").Value & ".jpg" 'bu alan her resim için de?i?tirilecek
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(10, "C") 'bu alan her resim için de?i?tirilecek RES?M BA?LANGIÇ ADRES?
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Left = Range("C10:I25").Left
.Height = Range("C10:I25").Height
.Width = Range("C10:I25").Width
.Top = Range("C10:I25").Top
End With
Set P = Nothing
End If

If Dir(yol & "\" & Cells(28, "L").Value & ".jpg") <> "" Then 'bu alan her resim için de?i?tirilecek
dosya = "\" & Cells(28, "L").Value & ".jpg" 'bu alan her resim için de?i?tirilecek
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(10, "M") 'bu alan her resim için de?i?tirilecek RES?M BA?LANGIÇ ADRES?
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Left = Range("M10:S25").Left
.Height = Range("M10:S25").Height
.Width = Range("M10:S25").Width
.Top = Range("M10:S25").Top
End With
Set P = Nothing
End If

If Dir(yol & "\" & Cells(52, "B").Value & ".jpg") <> "" Then 'bu alan her resim için de?i?tirilecek
dosya = "\" & Cells(52, "B").Value & ".jpg" 'bu alan her resim için de?i?tirilecek
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(34, "C") 'bu alan her resim için de?i?tirilecek RES?M BA?LANGIÇ ADRES?
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Left = Range("C34:I49").Left
.Height = Range("C34:I49").Height
.Width = Range("C34:I49").Width
.Top = Range("C34:I49").Top
End With
Set P = Nothing
End If

If Dir(yol & "\" & Cells(52, "L").Value & ".jpg") <> "" Then 'bu alan her resim için de?i?tirilecek
dosya = "\" & Cells(52, "L").Value & ".jpg" 'bu alan her resim için de?i?tirilecek
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(34, "M") 'bu alan her resim için de?i?tirilecek RES?M BA?LANGIÇ ADRES?
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Left = Range("M34:S49").Left
.Height = Range("M34:S49").Height
.Width = Range("M34:S49").Width
.Top = Range("M34:S49").Top
End With
Set P = Nothing
End If
Application.ScreenUpdating = True
End Sub

 

[owenefe]

yapay zeka ile halletim hatta birsürü farklı özellkler eklettim. Öncelikle resmin shape olarak gelip gömülmesini sağladı sonra en boy oranını korudu ve makroyu daha sadece hale getirdi. ve son olarak makronun benım belrittiğim tüm sayfalarda otomatik çalışmasını sağladı. Bu nasıl birşey ya

 

[sehzade42]

Hangi yapay zekâyı kullandınız. (ChatGPT, Copilot, DeepSeek vb.)