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

[bulut99]

Denedim hiçbir işlem yapmıyor(görünürde). Daha yeni 2016 versiyonuna geçtim. Versiyon farkından olabilir mi acaba?

 

[bulut99]

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

Pardon ben sadece resmi ekle modülünü kullanacağım için o bölümü almıştım, düzenleyince resim almaya başladı tek sorun. 5 satırdın sadece ilk ve son satırını alıyor aradakileri boş geçiyor. İlk satırdaki resme de 4. satırın ismini veriyor.

ActiveSheet.Shapes.AddPicture(yol, True, True, Range("F" & i).Left, Range("F" & i).Top, 60, Range("F" & i).Height)

Bölümündeki true'ların ne olduğunu söyleyebilir misin?

 

[EmrExcel16]

Bölümündeki true'ların ne olduğunu söyleyebilir misin?

İnceleyebilirsiniz..

Shapes.AddPicture

 

[alicimri]

Köprü adreslerinin C:\Users\xxx\Desktop\resimler\a.jpg şeklinde tam olması gerekiyor.
Eğer mesela resimler\a.jpg şeklinde ise tek tırnaklı satırdaki örneğe uygun değişikliği yapın. altındaki satırı silin.

Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
' yol = "C:\Users\xxx\Desktop\" & Range("E" & i).Hyperlinks(1).Address
yol = Range("E" & i).Hyperlinks(1).Address
Dim dene, varmı
Set dene = CreateObject("Scripting.FileSystemObject")
varmı = dene.FileExists(yol)
If varmı = True Then
 Set resim = ActiveSheet.Shapes.AddPicture(yol, True, True, Range("F" & i).Left, Range("F" & i).Top, 60, Range("F" & i).Height)
resim.Name = Range("B" & i)
Else
Range("F" & i).Value = "Dosya yolunu kontrol et."
End If
Next
End Sub

 

[alicimri]

Evde hapis kaldık, konu aklıma takıldı.
Sorun köprü kurarken resmin adresi Excel dosyasına göre göreceli olarak alıyor, halbuki resim ilave edilirken resmin tam yolunu istiyormuş. Buna göre kodu aşağıdaki şekilde değiştirdim. İlk önce excel dosyasının yolunu bulup sonra bu yolu köprünün yolu ile birleştirince oluyorr. Dilerim konu çözülmüştür.

Sub Resim_Ekle()
Dim yol As String
For i = 2 To Cells(Cells.Rows.Count, 5).End(3).Row
yol = ThisWorkbook.Path & "\" & Range("E" & i).Hyperlinks(1).Address
Dim dene, varmı
Set dene = CreateObject("Scripting.FileSystemObject")
varmı = dene.FileExists(yol)
If varmı = True Then
Set resim = ActiveSheet.Shapes.AddPicture(yol, True, True, Range("F" & i).Left, Range("F" & i).Top, 60, Range("F" & i).Height)
End If
Next
End Sub