Açıklama içerisine web'den resim getirmek

[sakiogluo]

Aşağıda yazılı olan makro ile C:\ de bulunan resimleri açıklama içerisine tek tek getirtebiliyorum. Benim istediğim, A1, A2, A3... hücerelerine kod yazdığımda (örnek "10205")www.websitesi.com/images/10205.jpg adresinden resmi adresleyip ilgili hücrenin içerisindeki açıklama içerisinde görüntüleyebilmek.
Yalnız aşağıdaki makrodan farklı olarak hücreye kodu yazıp enter e bastığımda resmin gelmesi lazım, yani hücre dinamik olacak.


Sub resimekle()
On Error Resume Next
For a = 7 To [c65536].End(3).Row
MsgBox "C:\resimler\" & Cells(a, "c") & ".JPG"
Cells(a, "c").Comment.Visible = True
Cells(a, "c").Comment.Shape.Select True
Selection.ShapeRange.Fill.UserPicture "C:\resimler\" & Cells(a, "c") & ".JPG"
Cells(a, "c").Comment.Visible = False
Next
End Sub

 

[sakiogluo]

incelemek isteyen olursa, elimdeki örnek dokümanı ekledim.
Teşekkürler.

 

[Ferhat Pazarçevirdi]

Bir örnek olması açısından; ekte verilen dosyada;

A1 hücresine "ata.gif" yazdığınız zaman; şu an bu sitede, üst tarafta gördüğünüz Atatürk ve Bayrak resminin, A1 hücresinin açıklamasına eklendiğini göreceksiniz.

Bunun için aşağıdaki gibi bir kod dizayn edildi.

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
            ByVal pCaller As Long, ByVal szURL As String, ByVal szFilename As String, _
            ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
Const sWebAdr As String = "[URL="http://www.excel.web.tr/"]http://www.excel.web.tr[/URL]"
Const sBlgAdr As String = "C:\"
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sWebRes As String
    Dim sBlgRes As String
    Dim sResUzanti As Variant
    Dim i As Integer
    Dim bRes As Boolean
    Dim oCmm As Comment
    
    If Target.Address = Range("A1").Address Then
        If Len(Target) = 0 Then
            If Not Range("A1").Comment Is Nothing Then
                Range("A1").Comment.Delete
            End If
        Else
        
            sUzanti = Array("gif", "jpg", "bmp", "png")
            
            For i = 0 To UBound(sUzanti)
                If Right(Range("A1"), 3) = sUzanti(i) Then bRes = True: Exit For
            Next i
            
            If bRes Then
                sWebRes = sWebAdr & "/" & Range("A1")
                sBlgRes = sBlgAdr & "WEBdenGelenResim" & "." & Right(Range("A1"), 3)
                
            
            Else
                Range("A1").Comment.Delete
                Exit Sub
            End If
            
            On Error Resume Next
            Kill sBlgAdr & "WEBdenGelenResim" & ".*"
            On Error GoTo 0
            
            URLDownloadToFile 0, sWebRes, sBlgRes, 0, 0
            
            If Range("A1").Comment Is Nothing Then
                Set oCmm = Range("A1").AddComment
            Else
                Set oCmm = Range("A1").Comment
            End If
            
            If Len(Dir(sBlgRes)) > 0 Then
                oCmm.Shape.Fill.UserPicture sBlgRes
            Else
                oCmm.Delete
            End If
        End If
    End If
 
    Set oCmm = Nothing
End Sub

 

[sakiogluo]

Ferhat Bey, gönderdiğiniz fonksiyon istediğime çok yakın ancak tek bir hücre üzerinde aktif. Benim uygulayacağım hücre alanları A2:A51 ve D251 olacak sanırım her hücre için ayrı formül adreslemesi gerecek. Birde gönderdiğiniz foksiyonda uzantıyıda girmek gerekiyor benim istediğim ise uzantının arka planda adreslenmesi mesela;
"http://www.excel.web.tr/images/buttons/" & Cells(a, "c") & ".JPG" gibi.
Ben gönderdiğiniz fonksiyonda bayağı uğraştım ama istediğim neticeyi alamadım. Yardımcı olursanız çok sevinirim, teşekkürler.

 

[Ferhat Pazarçevirdi]

Ferhat Bey, gönderdiğiniz fonksiyon istediğime çok yakın ancak tek bir hücre üzerinde aktif. Benim uygulayacağım hücre alanları A2:A51 ve D251 olacak sanırım her hücre için ayrı formül adreslemesi gerecek. Birde gönderdiğiniz foksiyonda uzantıyıda girmek gerekiyor benim istediğim ise uzantının arka planda adreslenmesi mesela;
"http://www.excel.web.tr/images/buttons/" & Cells(a, "c") & ".JPG" gibi.
Ben gönderdiğiniz fonksiyonda bayağı uğraştım ama istediğim neticeyi alamadım. Yardımcı olursanız çok sevinirim, teşekkürler.

Kodlar; aşağıda verildiği gibi revize edildi.

Bu haliyle; A1:A1000 aralığında hangi hücreye değer girerseniz, o hücrenin açıklamasına URL'deki resim gelir. Hücreye girdiğiniz tüm image isimlerinin "gif" uzantılı olduğu kabul edilmiştir.

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
            ByVal pCaller As Long, ByVal szURL As String, ByVal szFilename As String, _
            ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Const sWebAdr As String = "[URL]http://www.excel.web.tr/images/misc/[/URL]"
Const sBlgAdr As String = "C:\"
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sWebRes As String
    Dim sBlgRes As String
    Dim sResUzanti As Variant
    Dim i As Integer
    Dim bRes As Boolean
    Dim oCmm As Comment
    
    
    With Target
        If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
            If Len(Target) = 0 Then
                If Not .Comment Is Nothing Then
                    .Comment.Delete
                End If
            Else
                sWebRes = sWebAdr & .Text & ".gif"
                sBlgRes = sBlgAdr & "WEBdenGelenResim" & ".gif"
                
                On Error Resume Next
                Kill sBlgAdr & "WEBdenGelenResim" & ".*"
                On Error GoTo 0
            
                URLDownloadToFile 0, sWebRes, sBlgRes, 0, 0
            
                If .Comment Is Nothing Then
                    Set oCmm = .AddComment
                Else
                    Set oCmm = .Comment
                End If
            
                If Len(Dir(sBlgRes)) > 0 Then
                    oCmm.Shape.Fill.UserPicture sBlgRes
                Else
                    oCmm.Delete
                End If
            End If
        End If
    End With
    Set oCmm = Nothing
End Sub

Ekteki dosyayı da inceleyiniz.

 

[sakiogluo]

Ferhat Bey çok teşekkürler tam istediğim gibi olmuş.
Yalnız VBA ile ilgili hücrelerde kopyala, yapıştır, satır sil işlemleri yapınca hata veriyor.
Birde benim webdeki resimlerin ölçüsü değişebiliyor, "resize" özelliği eklenebilirmi?
yapabileceğiniz birşeyse iyi olur, yoksa çok önemli değil bu haliyle işimi görür.
Tekrar teşekkürler.

 

[ozgretmen]

Bende şunu merak ettim.Acaba bu kodalarda nasıl bir değişiklik yapar isek , hücreye yazmış olduğumuz isimle , aynı dizinde yer alan RESİMLERİM klasörü içerisindeki resimleri açıklama içerisine getirebiliriz ? İyi çalışmalar...