'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 |
---|