ExcelVBAでUserAgent指定型 URLDownloadToFile

そろそろIEだと弾かれるサイトが増えてきたので必要だ。

Function myURLDownloadToFile(aUrl As String, aFilepath As String) As Boolean

    Dim oStream As Object
    Dim myURL As String
    
    myURL = aUrl
    
    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    WinHttpReq.Option(4) = 13056 ' Ignore SSL Errors
    
    WinHttpReq.Open "GET", myURL, False
    
    'Grab Cert from Windows Cert Store
    'WinHttpReq.SetClientCertificate "CURRENT_USER\Root\CERTI"
    
    WinHttpReq.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.101 Safari/537.36"
    WinHttpReq.send
    
    myURL = WinHttpReq.responseBody
    
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile aFilepath, 2
        oStream.Close
    Else
        myURLDownloadToFile = False
        Exit Function
    End If

    myURLDownloadToFile = True

End Function

ネタ元