'I have a function extracting .JPG from sharepoint URL's but when I use it the data is unreadable

'This code generates files that cannot be opened

Sub DownloadPicturestoFile()

Dim FileUrl As String
Dim objXmlHttpReq As Object
Dim objStream As Object
Dim NamingVariable As String
Dim RowLoc As Integer
Dim FileNum As Integer
RowLoc = 2
FileNum = 1
Do Until ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 1) = ""
FileUrl = ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 6)
NamingVariable = ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 1) & " - " & ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 2)
NamingVariable = Replace(NamingVariable, "/", "_")
NamingVariable = Replace(NamingVariable, "\", "_")
NamingVariable = Replace(NamingVariable, "~", "_")
NamingVariable = Replace(NamingVariable, "#", "_")
NamingVariable = Replace(NamingVariable, ":", "_")
NamingVariable = Replace(NamingVariable, "<", "_")
NamingVariable = Replace(NamingVariable, ">", "_")
NamingVariable = Replace(NamingVariable, "?", "_")
NamingVariable = Replace(NamingVariable, "|", "_")
If ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 6) <> "" Then
Set objXmlHttpReq = CreateObject("MSXML2.ServerXMLHTTP.6.0")

objXmlHttpReq.Open "GET", FileUrl, False, "", ""
objXmlHttpReq.send

If objXmlHttpReq.Status = 200 Then
     Set objStream = CreateObject("ADODB.Stream")
     objStream.Open
     objStream.Type = 1
     objStream.write objXmlHttpReq.responseBody
     objStream.savetofile ThisWorkbook.Path & "\Pictures\" & NamingVariable & "-" & FileNum & ".jpg", 2
     objStream.Close
End If
RowLoc = RowLoc + 1
Else
RowLoc = RowLoc + 1
End If
If ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 2) = ThisWorkbook.Sheets("Sheet1").Cells(RowLoc - 1, 2) Then
FileNum = FileNum + 1
Else
FileNum = 1
End If
Loop
End Sub

'This code generates files that can be opened but gives access denied whenever it's not my own personal sharepoint where the files are stored (even if I have access) The weird thing about the code below is that it did work at first even when the URL was not my own sharepoint location.

Sub Save_image()
Dim oHTTP As Object
Dim sDestFolder As String
Dim sSrcUrl As String
Dim sImageFile As String
Dim RowLoc As Integer
Dim NamingVariable As String
Dim FileNum As Integer
FileNum = 1
RowLoc = 2
Do Until ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 1) = ""
If ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 6) <> "" Then
    
NamingVariable = ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 1) & " - " & 
ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 2) & FileNum
NamingVariable = Replace(NamingVariable, "/", "_")
NamingVariable = Replace(NamingVariable, "\", "_")
NamingVariable = Replace(NamingVariable, "~", "_")
NamingVariable = Replace(NamingVariable, "#", "_")
NamingVariable = Replace(NamingVariable, ":", "_")
NamingVariable = Replace(NamingVariable, "<", "_")
NamingVariable = Replace(NamingVariable, ">", "_")
NamingVariable = Replace(NamingVariable, "?", "_")
NamingVariable = Replace(NamingVariable, "|", "_")
If ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 2) = 
ThisWorkbook.Sheets("Sheet1").Cells(RowLoc - 1, 2) Then
FileNum = FileNum + 1
Else
FileNum = 1
End If
sDestFolder = ThisWorkbook.Path & "\Pictures\" & NamingVariable & "-" & FileNum & ".jpg"
sSrcUrl = ThisWorkbook.Sheets("Sheet1").Cells(RowLoc, 6)


sImageFile = Right(ActiveCell.Value, Len(ActiveCell.Value) - InStrRev(ActiveCell.Value, "/"))
Debug.Print sImageFile
ActiveCell.Offset(0, 2).Value = sImageFile


Set oHTTP = CreateObject("msxml2.XMLHTTP")
oHTTP.Open "GET", sSrcUrl, False
oHTTP.send

Set oStream = CreateObject("ADODB.Stream")
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
oStream.Type = adTypeBinary
oStream.Open

oStream.write oHTTP.responseBody
oStream.savetofile sDestFolder & ".jpg", adSaveCreateOverWrite

Set oStream = Nothing
Set oHTTP = Nothing
RowLoc = RowLoc + 1
Else
RowLoc = RowLoc + 1
End If
Loop
End Sub


Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution Source