Sitedeki resimleri hücreye getirme

[esnmz]

Merhaba;
Ekte yer alan excel sayfasında a hücresinde https://www.*****resim.jpg yazılı olan site adreslerindeki resimlerin B hücresine gelmesini istiyoruz. Bunun excelde yapılabilirliği var mı?

Uzman arkadaşlarımızın desteğini bekliyoruz. Teşekkür ederiz.

 

[turist]

Ekli dosyayı deneyin.
Makro çalışma süresi uzun olabilir, sayfada donmalar olabilir, müdahale etmeden beklerseniz sonuç alabilirsiniz.

 

[halit3]

Alternatif olsun
Dosyada kodların çalışması için referanslarda (clipboard.dll) dosyası seçili olmalı bu dosya yoksa kodlar çalışmaz bu dll dosyasınıda ekliyorum.
resimlerin gelmesi için a sutundaki hücrelere mause ile tıklamanız yeterli

 

[halit3]

Bu dosyada sayfa2 deki komut düğmesine her tıklamanız da 20 adet resim gelecektir.

 

[Haluk]

Bir alternatif de ben ekledim...

.

 

[5353]

Bir alternatif de ben ekledim...

.

üstat boş satır oldu mu hata veriyor. Boş satırda getirmesede olur. Hata uyarısı verip makro bölümüne atmasını engelleyerek bunu yapabilir miyiz.

 

[Haluk]

üstat boş satır oldu mu hata veriyor. Boş satırda getirmesede olur. Hata uyarısı verip makro bölümüne atmasını engelleyerek bunu yapabilir miyiz.

Sub Test()
'   Haluk -29 / 4 / 2021
'   sa4truss@gmail.com
'   https://excelhaluk.blogspot.com/

    Dim FileNum As Long
    Dim FileData() As Byte
    Dim MyFile As String
    Dim WHTTP As Object, WshShell As Object
    Dim strMyDocuments As String
    Dim noA As Integer, i As Integer
    
    On Error Resume Next
        Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
        If Err.Number <> 0 Then
            Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
        End If
    On Error GoTo 0
    
    Set WshShell = CreateObject("WScript.Shell")
    
    strMyDocuments = WshShell.SpecialFolders("MyDocuments")
    MyFolder = strMyDocuments & "\Resimler"
    
    If Dir(MyFolder, vbDirectory) = Empty Then MkDir MyFolder
    
    noA = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To noA
        DoEvents
        Cells(i, 2).Select
        
        MyFile = Range("A" & i).Text
        If MyFile <> "" Then
            WHTTP.Open "GET", MyFile, False
            WHTTP.Send
            FileData = WHTTP.ResponseBody
            If WHTTP.Status = 200 Then
                FileNum = FreeFile
                
                Open MyFolder & "\" & "Resim-" & i & ".jpg" For Binary Access Write As #FileNum
                    Put #FileNum, 1, FileData
                Close #FileNum
                
                Set MyRng = Range("B" & i)
                PicFile = MyFolder & "\" & "Resim-" & i & ".jpg"
                PicTop = MyRng.Top
                PicLeft = MyRng.Left
                PicW = MyRng.Width
                PicH = MyRng.Height
                Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
        End If
        End If
    Next
    Range("B1").Select
    Set MyRng = Nothing
    Set MyPic = Nothing
    Set WHTTP = Nothing
End Sub

.