Web adresinden resim alma

[işsiz123]

Selam Arkadaşlar


Benim yapmak istediğim ve yapamadığım
örnek olarak a1 hücresinde ("http://webbox.imgix.net/images/rggbujpevggsubth/8598068c-c4c5-4b98-b91b-5f7f4efe8d9c.jpg?auto=enhance,compress&fit=crop&w=600&h=450") bu adres vardır bu adresteki resmi otomatik olarak b2 hücresine getirsin

demem o ki a1 hücresindeki adreste hangi resim varsa onu otomatik olarak b2 hücresine alsın



saygılar

 

[TEGCreative]

Merhaba ; direk ekleme gibi birşey yapamadım ama şöyle birşey yaptım belki ufkunuzu açar size ilham verir ;

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
    Private Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public Function TEGCreative(ByVal url As String) As Picture
        Dim IPic(15) As Byte
        CLSIDFromString StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IPic(0)
        OleLoadPicturePath StrPtr(url), 0&, 0&, 0&, IPic(0), TEGCreative
    End Function

Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Image1.Picture = TEGCreative(Range("A1").Value)
End Sub

Sayfa1 üzerine bir ActiveX denetimli İmage nesnesi koyun ve Sayfa1'in VBA koduna da kodları yapıştırın. Artık A1 e hangi yolu yazdıysanız İmage nesnesine tıkladığınızda o resim gelir.

Örnek : Buradan İndirebilirsiniz.

 

[işsiz123]

TEGCreative teşekkürler ancak istediğim gibi olmadı

 

[Korhan Ayhan]

Deneyiniz.

Sub Webden_Resim_Al(Link As String, Hedef As Range)
    With Hedef.Parent
        .Pictures.Insert Link
        .Shapes(.Shapes.Count).Left = Hedef.Left
        .Shapes(.Shapes.Count).Top = Hedef.Top
    End With
End Sub
 
Sub Test()
    Call Webden_Resim_Al("http://webbox.imgix.net/images/rggbujpevggsubth/8598068c-c4c5-4b98-b91b-5f7f4efe8d9c.jpg?auto=enhance,compress&fit=crop&w=%20600&h=450", Sheets("Sayfa1").Range("A1"))
End Sub

 

[işsiz123]

kod düzeltme

Sub InsertPic()
Dim pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator

Set rng = Range("B1:B7")  '<~~ Modify this range as needed. Assumes image link URL in column A.
For Each cl In rng
pic = cl.Offset(0, -1)

    Set myPicture = ActiveSheet.Pictures.Insert(pic)
    '
    'you can play with this to manipulate the size & position of the picture.
    ' currently this shrinks the picture to fit inside the cell.
    With myPicture
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = cl.Width
        .Height = cl.Height
        .Top = Rows(cl.Row).Top
        .Left = Columns(cl.Column).Left
    End With
    '

 Next

 End Sub

kodu hata veriyor

 

[Murat OSMA]

Resim linkleri A1:A7 arasında olduğunu düşünürsek, kodları bu şekilde revize edebilirsiniz.

[FONT="Trebuchet MS"][SIZE="2"]Sub InsertPic()
    Dim pic As String, myPicture As Picture, rng As Range, cl As Range
    Set rng = Range("A1:A7")
    On Error Resume Next
    For Each cl In rng
        pic = cl.Value
        Set myPicture = ActiveSheet.Pictures.Insert(pic)
        With myPicture
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = cl.Offset(0, 1).Width
            .Height = cl.Offset(0, 1).Height
            .Top = Rows(cl.Offset(0, 1).Row).Top
            .Left = Columns(cl.Offset(0, 1).Column).Left
        End With
    Next cl
 End Sub[/SIZE][/FONT]

 

[işsiz123]

murat osma arkadaşım eline sağlık olduson bir şe
url a1 yazıyorsak resimde b1 gelsin

 

[Murat OSMA]

İsteğinizi anlamadım.
Biraz daha açık izah eder misiniz?​

 

[işsiz123]

kodu a1 hücresine kopyaladıgımda ve makroyu çalıştırdığımda resim tek bir noktaya gelmesin . İstediğim a satırına url (resim yolunu nu kopyaladıgımda) resim kendiliğinden b sutunundaki yerine kopyalansın a1 hücresinde hanhi url yolu varsa b1 hücresine o resim gelsin

 

[Murat OSMA]

Anladığım kadarını söyleyeyim; şu an kodlar zaten o şekilde çalışır.
A1 hücresinden A7 hücresine kadar resim linklerini yazın ve kodu çalıştırın, resimlerin B sütunundaki ilgili satırlara geldiğini göreceksiniz.

İsterseniz üzerinde çalıştığınız dosyayı yollayın onun üzerinde gerekli işlemleri yapıp tekrar size ileteyim.​

 

[işsiz123]

dosya ile ilgili resim ekledim bakarsanız sevinirim saygılar

 

[işsiz123]

http://s9.dosya.tc/server/uj68g6/183_512013572233470_7067527207236079026_n.jpg.html

dosya ile ilgili resim ekledim bakarsanız sevinirim saygılar

 

[işsiz123]

http://s9.dosya.tc/server/uj68g6/183_512013572233470_7067527207236079026_n.jpg.html

 

[Korhan Ayhan]

Deneyiniz.

Sub Resim_Al()
    Dim Veri As Range, Son As Long
    
    Application.ScreenUpdating = False
        
    Son = Cells(Rows.Count, 1).End(3).Row
    
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    
    For Each Veri In Range("A2:A" & Son)
        Call Webden_Resim_Al(Veri.Value, Veri.Offset(0, 1))
    Next

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Sub Webden_Resim_Al(Link As String, Hedef As Range)
    Dim Resim As Object
    With Hedef.Parent
        .Pictures.Insert Link
         Set Resim = .Shapes(.Shapes.Count)
         With Resim
            .LockAspectRatio = msoFalse
            .Left = Hedef.Left
            .Top = Hedef.Top
            .Width = Hedef.Width
            .Height = Hedef.Height
         End With
    End With
End Sub

 

[işsiz123]

Korhan Ayhan Teşekkürler kodları yapıştırdığımızda otomatik olsa daha iyi olurdu SAYGILAR.

 

[Korhan Ayhan]

Üstteki mesajımdaki kodları boş bir modüle uygulayın. Daha sonra aşağıdaki işlemi uygulayın.

İlgili sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Resim_Al
End Sub

Kodları kopyala yapıştır yaptıktan sonra herhangi bir hücreyi seçince kod otomatik çalışacaktır.

 

[işsiz123]

Korhan Ayhan arkadaşım çok teşekkürler ederim lakin bir sorun daha var. sayfa yenilendiğinde tüm resimler tekrar yenileniyor ilerde resimler çogaldıgında hepsini yenilemek çok zaman alır. Demem o ki hangi hücre değişiklik yapılırsa o hücre tek yenilensin diğerleri sabit kalsın

 

[Korhan Ayhan]

Boş bir modüle aşağıdaki kodları uygulayınız.

Sub Resim_Al()
    Dim Veri As Range
    
    Application.ScreenUpdating = False
        
    For Each Veri In Selection
        If Veri.Column = 1 Then Call Webden_Resim_Al(Veri.Value, Veri.Offset(0, 1))
    Next

    Application.ScreenUpdating = True
End Sub

Sub Webden_Resim_Al(Link As String, Hedef As Range)
    Dim Resim As Object
    If Link <> "" Then
        For Each Resim In ActiveSheet.Shapes
            If Not Intersect(Resim.TopLeftCell, Hedef) Is Nothing Then Exit Sub
        Next
        
        With Hedef.Parent
            .Pictures.Insert Link
             Set Resim = .Shapes(.Shapes.Count)
             With Resim
                .LockAspectRatio = msoFalse
                .Left = Hedef.Left
                .Top = Hedef.Top
                .Width = Hedef.Width
                .Height = Hedef.Height
             End With
        End With
    End If
End Sub

Sayfanızın kod bölümüne ise aşağıdaki kodları uygulayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then Exit Sub
    Resim_Al
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then Exit Sub
    Resim_Al
End Sub

 

[işsiz123]

Korhan Ayhan teşekkürler sorun yok.

 

[euphrates55]

merhabalar. bunu formülle nasıl kullanabiliyoruz. örnek olarak a1 hücresine adres yazsam, b1 hücresine ne yazarsam yine b1 hücresine ya da c1 hücresine resim gelmiş olacaktır.
2. aşama sorum ise. webden alınacak resim gif ise yani hareketli ise nasıl yol izlenmeli. excelde de animasyonlu olabilir mi?