To help protect your privacy, PowerPoint has blocked automatic download..

[Lewzerrrr]

Hi,

I created a macro that will pull an image from a URL and then save it into my directory via PowerPoint. Before the macro I was manually getting the pictures and using the save macro after that which worked fine but now with this pull URL I'm suddenly getting this message.

How do I prevent this? I need it to be coded as this file is used by others so manually changing their privacy would be a nightmare.

Any solutions? Is there a way to save without PP? Basically what the save is doing is I have pictures throughout C2:C & LR with their corresponding FileNames in A2:A & LR. Save each picture to the directory.

See below codes.

Thanks,

Private Sub PullPicturesFromWeb()

Dim Pic As Picture, WS As Worksheet, LR As Long, RNG As Range, URL As String
    
Set WS = ThisWorkbook.Sheets("Pictures Not Found DIR")
LR = WS.Cells(Rows.Count, "A").End(xlUp).Row
Set RNG = WS.Range("A2:A" & LR)


Application.ScreenUpdating = False
    
    For Each R In RNG
    
    URL = "http://media.topshop.com/wcsstore/TopShop/images/catalog/TS" & R.Value & "_Large_F_1.jpg"
    
        With ActiveSheet.Range("H" & R.Row)
        On Error Resume Next
            Set Pic = .Parent.Pictures.Insert(URL)
            With .Offset(, -5)
                Pic.Top = .Top
                Pic.Left = .Left
                Pic.Height = .Height
                Pic.Width = .Width
            End With
            
            With Pic
                .Top = Pic.Top + 8.7
                .Left = Pic.Left + 26.1
                .Width = 92.6929242
                .Height = 100.629933
            End With
            
            Set Pic = Nothing
        End With
    
    Next
    
Set WS = Nothing


Application.ScreenUpdating = True


End Sub

Sub SaveImages()

Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets("Pictures Not Found DIR")


Dim ppt As Object, ps As Variant, slide As Variant


    Set ppt = CreateObject("PowerPoint.application")
    Set ps = ppt.presentations.Add
    Set slide = ps.slides.Add(1, 1)
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With


    Dim shp As Shape, shpName$
    For Each shp In WS.Shapes
    
        shpName = lFolder & shp.TopLeftCell.Offset(0, -2) & ".png"
        
        If shp.TopLeftCell.Column <> 3 Then
        
        Else
        
            If FileExists(shpName) = True Then
            
                
            Else
            
            shp.Copy
            
                With slide
                    .Shapes.Paste
                    .Shapes(.Shapes.Count).Export shpName, 2
                    .Shapes(.Shapes.Count).Delete
                End With
            
            
            End If
        End If
    Next shp


    With ps
        .Saved = True
        .Close
    End With
    ppt.Quit
    Set ppt = Nothing
    
        With Application
            .ScreenUpdating = True
            .DisplayAlerts = True
            .EnableEvents = True
        End With
        
    
End Sub

 

[Lewzerrrr]

Or an even simpler solution but can’t seem to find a solid answer online.. would it be possible to have a list of values in A2:A & LastRow, put the value into a variable which then goes into the URL, skip the inserting into Excel and download it straight to a file path using the value as it’s file name & “.png”

It would need to perform a check to see if this file already exists and would then once downloaded from the URL straight to folder, return a msgbox “Download completed. X images were not found.”

Very new to working with shapes and URL’s but will continue trying to find out