Soru Köprü oluşturulmuş resmi excele çekmek

[bulut99]

Merhaba,

Köprü ile linklerini oluşturduğum resimleri excel çalışma sayfasına gömmek istiyorum. Çok fazla resim olduğu için tek tek yapmak haftalarımı alabilir. Bunun kolay bir yolu var mıdır? Makrosuz halletmeye çalışıyorum ama olmayacak sanırım. Örnek dosya

 

[alicimri]

Resmi F sütununda köprünün bulunduğu hücre ile aynı satıra yapıştırıyor, ancak F sütunundaki hücrelerin boyutunu (en, boy, genişlik ve yükseklik) ayarlamanız gerekiyor.

Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Width = Range("F" & i).Width
.Height = Range("F" & i).Height
.Name = Range("B" & i)
End With
Next
End Sub

 

[bulut99]

Resmi F sütununda köprünün bulunduğu hücre ile aynı satıra yapıştırıyor, ancak F sütunundaki hücrelerin boyutunu (en, boy, genişlik ve yükseklik) ayarlamanız gerekiyor.

Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Width = Range("F" & i).Width
.Height = Range("F" & i).Height
.Name = Range("B" & i)
End With
Next
End Sub

Çok teşekkür ederim. Tam aklımdaki gibi çalışıyor. En kısa zamanda makro öğrenip bunun gibi basit sorularla sizleri rahatsız etmeyeceğim.

 

[alicimri]

Makroyu biraz geliştirdim, Resme tıklayınca resmi büyütüyor, tekrar tıklayınca eski boyutuna getiriyor. Hücre boyutu ile bir ayarlama yapmanıza gerek kalmıyor.

Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Height = Range("F" & i).Height
.Name = Range("B" & i)
.OnAction = "Resim_Büyüt"
End With
Next
End Sub
Sub Resim_Büyüt()
Dim ActiveShape As Shape
  ButtonName = Application.Caller
  Set ActiveShape = ActiveSheet.Shapes(ButtonName)
If ActiveSheet.Shapes(ActiveShape.Name).Width = 15 Then
ActiveSheet.Shapes(ActiveShape.Name).Width = 250
Else
ActiveSheet.Shapes(ActiveShape.Name).Width = 15
End If
End Sub

 

[bulut99]

Makroyu biraz geliştirdim, Resme tıklayınca resmi büyütüyor, tekrar tıklayınca eski boyutuna getiriyor. Hücre boyutu ile bir ayarlama yapmanıza gerek kalmıyor.

Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
With ActiveSheet.Pictures.Insert(yol)
.Left = Range("F" & i).Left 'Resmin görüleceği hücre Soldan
.Top = Range("F" & i).Top 'Resmin görüleceği hücre Üstten
.Height = Range("F" & i).Height
.Name = Range("B" & i)
.OnAction = "Resim_Büyüt"
End With
Next
End Sub
Sub Resim_Büyüt()
Dim ActiveShape As Shape
  ButtonName = Application.Caller
  Set ActiveShape = ActiveSheet.Shapes(ButtonName)
If ActiveSheet.Shapes(ActiveShape.Name).Width = 15 Then
ActiveSheet.Shapes(ActiveShape.Name).Width = 250
Else
ActiveSheet.Shapes(ActiveShape.Name).Width = 15
End If
End Sub

Type mismatch hatası veriyor.

 

[alicimri]

Hatayı hangi satırda veriyor.

 

[bulut99]

Hepsinde veriyor. Bu arada bütün sayfalarda çalışan ilk kod bir sayfada çalışmadı ilginç bir şekilde. 400 yazan bir hata verdi, açıklamasız.

 

[alicimri]

https://www.dosya.tc/server27/1awmn1/s.zip.html
Yukarıdaki örnek dosyayı deneyin

 

[bulut99]

İlk makroda 400 hatası, diğerlerinde compile error hatası alıyorum. Herhangi bir noktada hata yapmıyorumdur umarım.

 

[alicimri]

Kusura bakmayın yanlış dosya yüklemişim.

s1.zip dosyasını indir - download

s1.zip dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[bulut99]

Estağfurullah.
Run-time error '1004':
Pictures sınıfının Insert özelliği alınamıyor. diye bir hata veriyor. With ActiveSheet.Pictures.Insert(yol) satırında

 

[alicimri]

Biraz acele ettim E2 ve E3 deki köprü adresini değiştirmiştim.
Makronun başını aşağıdaki şekilde değiştirin
Sub Resim_Ekle()
On Error Resume Next

 

[bulut99]

On Error Resume Next hata vermesi halinde sıradaki satıra geçiriyor sanırım. Hatayı "With ActiveSheet.Pictures.Insert(yol)" satırında aldığım için hiçbir işlem yapmıyor. Şikayetçi gibi görünmek istemiyorum ama; bir de tam olarak açıklamadığım için sanırım; resim dosyalarını kaynak dosyalara bağlı olacak şekilde yazmışsınız makroyu. Ben Excel dosyasına gömmek istiyordum. Yani excel dosyası taşındığında resim klasörüyle bağlantısı kalmasın istiyorum. Başınızı çok ağrıttım. Hakkınızı helal edin lütfen

 

[aspire343434]

bende de çalışmadı hocam linke basınca mı geliyor resim tam anlamadım kurguyu da

 

[alicimri]

Resin_Ekle Makrosunu sadece bir defa çalıştıracaksınız, Resimler excele gömülecek. Sonra silebilirsiniz Makro E sütunundaki köprü adresleri doğru ise ve öyle bir resim dosyası varsa resimleri excel e ekliyor. Resimleri doğru şekilde aldıktan sonra F sütunu da silebilir siniz
Resim_Büyüt Makrosunu devamlı büyütmek küçültmek için kullanacaksınız.

 

[bulut99]

Resimler gömülü hale gelmiyor maalesef. Dosyayı başka bir yere kopyaladığımda resimler gidiyor.

 

[alicimri]

Versiyon farklılığından mı diye düşünüyorum.
#10 nolu mesajdaki dosyayı indirip, ilk açtığınızda F2 ve F3 hücrelerinde resim var mıydı?

 

[EmrExcel16]

Merhaba Ali bey , resimlerin gitmesi kullanılan ActiveSheet.Pictures.Insert yönteminden kaynaklanıyor olabilir , bu tür durumlarda aşağıda linkini verdiğim konu size yol gösterecektir diye tahmin ediyorum .

https://www.excel.web.tr/threads/klasoerdeki-tuem-resimleri-excel-sayfasina-eklemek.184377/#post-1017491

 

[alicimri]

Ben ofis 2007 ile çalışıyorum, şu an başka bilgisayardan denemem mümkün değil. Siz "makro kaydet" tıklayıp, manuel olarak bir resim ekledikten sonra "makro kaydet" durdurup bu makroyu mesaja ekleye bilirmisiniz.

 

[alicimri]

Sn EmrExcel16 Sizin önerinize göre kodları yeniledim.
Sayın bulut99 F sütunundaki hücrelerin boyutunu istediğiniz gibi ayarlayın ve kodlarda 60 olarak ayarladığım resim genişliği siz kendinize göre değiştirin.

Sub Resim_Ekle()
On Error Resume Next
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = Range("E" & i).Hyperlinks(1).Address
 Set resim = ActiveSheet.Shapes.AddPicture(yol, True, True, Range("F" & i).Left, Range("F" & i).Top, 60, Range("F" & i).Height)
resim.OnAction = "Resim_Büyüt"
resim.Name = Range("B" & i)
Next
End Sub
Sub Resim_Büyüt()
Dim ActiveShape As Shape
  ButtonName = Application.Caller
  Set ActiveShape = ActiveSheet.Shapes(ButtonName)
If ActiveSheet.Shapes(ActiveShape.Name).Width = 60 Then
ActiveSheet.Shapes(ActiveShape.Name).Width = 60 * 3
ActiveSheet.Shapes(ActiveShape.Name).Height = Range("F2").Height * 3
Else
ActiveSheet.Shapes(ActiveShape.Name).Height = Range("F2").Height
ActiveSheet.Shapes(ActiveShape.Name).Width = 60
End If
End Sub