NEW URL Downloader (WinHTTP)

[SpriggsySpriggs]

I have made a new version of my URL downloader. This one uses the newer WinHTTP functions. It is based on the MSDN example Authentication in WinHTTP.
Like the other version, this starts up with a console window so you can easily paste your URL.

Code: (Select All)

Option Explicit
$NoPrefix

Const WINHTTP_AUTH_TARGET_SERVER = &H00000000
Const WINHTTP_AUTH_TARGET_PROXY = &H00000001

Const WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0
Const WINHTTP_ACCESS_TYPE_NO_PROXY = 1
Const WINHTTP_ACCESS_TYPE_NAMED_PROXY = 3

Const WINHTTP_NO_PROXY_NAME = 0
Const WINHTTP_NO_PROXY_BYPASS = 0

Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_DEFAULT_HTTPS_PORT = 443

Const WINHTTP_NO_REFERER = 0
Const WINHTTP_DEFAULT_ACCEPT_TYPES = 0

Const WINHTTP_FLAG_SECURE = &H00800000

Const WINHTTP_NO_ADDITIONAL_HEADERS = 0
Const WINHTTP_NO_REQUEST_DATA = 0

Const WINHTTP_ERROR_BASE = 12000
Const ERROR_WINHTTP_RESEND_REQUEST = WINHTTP_ERROR_BASE + 32

Const WINHTTP_QUERY_STATUS_CODE = 19
Const WINHTTP_QUERY_FLAG_NUMBER = &H20000000
Const WINHTTP_QUERY_CONTENT_LENGTH = 5
'Const WINHTTP_QUERY_CONTENT_TYPE = 1
Const WINHTTP_QUERY_CUSTOM = 65535

Const KILOBYTE = 1024
Const MEGABYTE = KILOBYTE ^ 2
Const GIGABYTE = KILOBYTE ^ 3
Const TERABYTE = KILOBYTE ^ 4

Declare Dynamic Library "winhttp"
    Function WinHttpOpen%& (pszAgentW As String, Byval dwAccessType As Unsigned Long, Byval pszProxyW As Offset, Byval pszProxyBypassW As Offset, Byval dwFlags As Unsigned Long)
    Function WinHttpConnect%& (ByVal hSession As Offset, Byval pswzServerName As Offset, Byval nServerPort As Unsigned Integer, Byval dwReserved As Unsigned Long)
    Function WinHttpOpenRequest%& (ByVal hConnect As Offset, pwszVerb As String, Byval pwszObjectName As Offset, Byval pwszVersion As Offset, Byval pwszReferer As Offset, Byval ppwszAcceptTypes As Offset, Byval dwFlags As Unsigned Long)
    Function WinHttpSendRequest& (ByVal hRequest As Offset, Byval lpszHeaders As Offset, Byval dwHeadersLength As Unsigned Long, Byval lpOptional As Offset, Byval dwOptionalLength As Unsigned Long, Byval dwTotalLength As Unsigned Long, Byval dwContext As Unsigned Long)
    Function WinHttpReceiveResponse& (ByVal hRequest As Offset, Byval lpReserved As Offset)
    Function WinHttpQueryDataAvailable& (ByVal hRequest As Offset, Byval lpdwNumberOfBytesAvailable As Offset)
    Function WinHttpReadData& (ByVal hRequest As Offset, Byval lpBuffer As Offset, Byval dwNumberOfBytesToRead As Unsigned Long, Byval lpdwNumberOfBytesRead As Offset)
    Function WinHttpQueryHeaders& (ByVal hRequest As Offset, Byval dwInfoLevel As Unsigned Long, Byval pwszName As Offset, Byval lpBuffer As Offset, Byval lpdwBufferLength As Offset, Byval lpdwIndex As Offset)
    Sub WinHttpQueryHeaders (ByVal hRequest As Offset, Byval dwInfoLevel As Unsigned Long, Byval pwszName As Offset, Byval lpBuffer As Offset, Byval lpdwBufferLength As Offset, Byval lpdwIndex As Offset)
    Sub WinHttpCloseHandle (ByVal hInternet As Offset)
End Declare

Declare Library
    Function GetLastError~& ()
End Declare

Declare Dynamic Library "shlwapi"
    Function UrlUnescape& Alias "UrlUnescapeA" (ByVal pszUrl As Offset, Byval pszUnescaped As Offset, Byval pcchUnescaped As Offset, Byval dwFlags As Unsigned Long)
End Declare

Screen NewImage(480, 120, 32)
$ScreenHide
_ScreenHide
$Console
Dest Console

Title "WinHTTP URL Downloader"
ConsoleTitle "Enter Link"

Dim As String link
Do
    Cls
    Line Input "Link: ", link
Loop Until link <> ""

ScreenShow
Title Title$ + " - " + link

Console Off
Dest 0

WinHttpDownload link

Sub WinHttpDownload (url As String)
    Dim As String server, path, ansipath
    DivideURL url, server, path
    ansipath = path
    Dim As Long useSSL: useSSL = -1
    server = ANSIToUnicode(server)
    path = ANSIToUnicode(path)

    Dim As Unsigned Long dwStatusCode, dwSupportedSchemes, dwFirstScheme, dwSelectedScheme, dwTarget, dwLastStatus, dwSize: dwSize = Len(dwSize)
    Dim As Long bResults, bDone
    Dim As Offset hSession, hConnect, hRequest

    hSession = WinHttpOpen(ANSIToUnicode("Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/42.0.2311.135 Safari/537.36 Edge/12.246" + Chr$(0)), WINHTTP_ACCESS_TYPE_DEFAULT_PROXY, WINHTTP_NO_PROXY_NAME, WINHTTP_NO_PROXY_BYPASS, 0)

    Dim As Unsigned Integer nPort
    If useSSL Then nPort = INTERNET_DEFAULT_HTTPS_PORT Else nPort = INTERNET_DEFAULT_HTTP_PORT

    If hSession Then hConnect = WinHttpConnect(hSession, Offset(server), nPort, 0)

    If hConnect Then

        If useSSL Then
            hRequest = WinHttpOpenRequest(hConnect, ANSIToUnicode("GET" + Chr$(0)), Offset(path), 0, WINHTTP_NO_REFERER, WINHTTP_DEFAULT_ACCEPT_TYPES, WINHTTP_FLAG_SECURE)
        Else
            hRequest = WinHttpOpenRequest(hConnect, ANSIToUnicode("GET" + Chr$(0)), Offset(path), 0, WINHTTP_NO_REFERER, WINHTTP_DEFAULT_ACCEPT_TYPES, 0)
        End If
    End If

    If hRequest = 0 Then bDone = -1
    Dim As Single y: y = Timer
    bResults = WinHttpSendRequest(hRequest, WINHTTP_NO_ADDITIONAL_HEADERS, 0, WINHTTP_NO_REQUEST_DATA, 0, 0, 0)

    If bResults Then bResults = WinHttpReceiveResponse(hRequest, 0)

    If bResults Then bResults = WinHttpQueryHeaders(hRequest, WINHTTP_QUERY_STATUS_CODE Or WINHTTP_QUERY_FLAG_NUMBER, 0, Offset(dwStatusCode), Offset(dwSize), 0)

    If bResults Then
        Select Case dwStatusCode
            Case 200
                Dim As Unsigned Long totalsize, lentotal: lentotal = Len(totalsize)
                WinHttpQueryHeaders hRequest, WINHTTP_QUERY_CONTENT_LENGTH Or WINHTTP_QUERY_FLAG_NUMBER, 0, Offset(totalsize), Offset(lentotal), 0
                Dim As String buffer, outstring
                Dim As Unsigned Long bytesread, bytesavailable
                If WinHttpQueryDataAvailable(hRequest, Offset(bytesavailable)) Then
                    Dim As Unsigned Long bytesout, bytesforrate
                    Dim As Long outfile: outfile = FreeFile
                    Dim As String filepath: filepath = ansipath
                    filepath = Mid$(filepath, InStrRev(filepath, "/") + 1)
                    If InStr(filepath, ".") Then filepath = Mid$(filepath, 1, InStrRev(filepath, ".") + 3)
                    Dim As String parsedfilepath: parsedfilepath = Space$(1024)
                    Dim As Unsigned Long requiredbytes: requiredbytes = Len(parsedfilepath)
                    Dim As String toparse: toparse = filepath + Chr$(0)
                    If UrlUnescape(Offset(toparse), Offset(parsedfilepath), Offset(requiredbytes), 0) = 0 Then
                        filepath = Mid$(parsedfilepath, 1, requiredbytes)
                        Open "B", outfile, filepath
                    Else
                        Open "B", outfile, filepath
                    End If
                    Do
                        If WinHttpQueryDataAvailable(hRequest, Offset(bytesavailable)) Then
                            buffer = Space$(bytesavailable)
                            If WinHttpReadData(hRequest, Offset(buffer), Len(buffer), Offset(bytesread)) Then
                                If bytesread > 0 Then
                                    outstring = Mid$(buffer, 1, bytesread)
                                    bytesout = bytesout + bytesread
                                    bytesforrate = bytesforrate + bytesread
                                    Put outfile, , outstring
                                End If
                            End If
                        End If
                        Cls
                        If totalsize > 0 Then
                            Select Case bytesout
                                Case Is < KILOBYTE
                                    Print Using "#### B downloaded of "; bytesout;
                                Case Is < MEGABYTE And bytesout >= KILOBYTE
                                    Print Using "####.## KB downloaded of "; bytesout / KILOBYTE;
                                Case Is < GIGABYTE And bytesout >= MEGABYTE
                                    Print Using "####.## MB downloaded of "; bytesout / MEGABYTE;
                                Case Is < TERABYTE And bytesout >= GIGABYTE
                                    Print Using "####.## GB downloaded of "; bytesout / GIGABYTE;
                            End Select
                            Select Case totalsize
                                Case Is < KILOBYTE
                                    Print Using "#### B"; totalsize
                                Case Is < MEGABYTE And totalsize >= KILOBYTE
                                    Print Using "####.## KB"; totalsize / KILOBYTE
                                Case Is < GIGABYTE And totalsize >= MEGABYTE
                                    Print Using "####.## MB"; totalsize / MEGABYTE
                                Case Is < TERABYTE And totalsize >= GIGABYTE
                                    Print Using "####.## GB"; totalsize / GIGABYTE
                            End Select
                            Print Using "###.##%"; bytesout / totalsize * 100
                        Else
                            Select Case bytesout
                                Case Is < KILOBYTE
                                    Print Using "#### B downloaded"; bytesout
                                Case Is < MEGABYTE And bytesout >= KILOBYTE
                                    Print Using "####.## KB downloaded"; bytesout / KILOBYTE
                                Case Is < GIGABYTE And bytesout >= MEGABYTE
                                    Print Using "####.## MB downloaded"; bytesout / MEGABYTE
                                Case Is < TERABYTE And bytesout >= GIGABYTE
                                    Print Using "####.## GB downloaded"; bytesout / GIGABYTE
                            End Select
                        End If
                        Dim As Single Rate
                        Dim As Integer x: x = Round(Timer - y)
                        If x = 1 Then
                            Rate = (bytesforrate / x)
                            bytesforrate = 0
                            y = Timer
                        End If
                        Select Case Rate
                            Case Is < KILOBYTE
                                Print Using "Rate: #### Bps"; Rate
                            Case Is < MEGABYTE And Rate >= KILOBYTE
                                Print Using "Rate: ####.## KBps"; Rate / KILOBYTE
                            Case Is < GIGABYTE And Rate >= MEGABYTE
                                Print Using "Rate: ####.## MBps"; Rate / MEGABYTE
                            Case Is < TERABYTE And Rate >= GIGABYTE
                                Print Using "Rate: ####.## GBps"; Rate / GIGABYTE
                        End Select
                        Display
                    Loop While bytesavailable > 0
                End If
                Close outfile
                Print "The resource was successfully retrieved."
                Print "Saved to "; filepath
                bDone = -1
                Exit Case
            Case Else
                Print "Error. Status code"; dwStatusCode; "returned"
                bDone = -1
        End Select
    End If
    dwLastStatus = dwStatusCode
    If bResults = 0 Then
        Dim As Unsigned Long dwLastError: dwLastError = GetLastError
        Print "Error"; dwLastError; "has occurred"
    End If
    If hRequest Then WinHttpCloseHandle hRequest
    If hConnect Then WinHttpCloseHandle hConnect
    If hSession Then WinHttpCloseHandle hSession
End Sub

Sub DivideURL (url As String, server As String, path As String)
    If InStr(url, "http:") Or InStr(url, "https:") Then
        server = Mid$(url, InStr(url, "/") + 2)
        If InStr(server, "/") Then
            server = Mid$(server, 1, InStr(server, "/") - 1)
        End If
    Else
        If InStr(url, "/") Then
            server = Mid$(url, 1, InStr(url, "/") - 1)
        End If
    End If
    path = Mid$(url, InStr(url, server) + Len(server))
End Sub

Declare CustomType Library
    Function WideCharToMultiByte& (ByVal CodePage As _Unsigned Long, Byval dwFlags As _Unsigned Long, Byval lpWideCharStr As _Offset, Byval cchWideChar As Long, Byval lpMultiByteStr As _Offset, Byval cbMultiByte As Long, Byval lpDefaultChar As _Offset, Byval lpUsedDefaultChar As _Offset)
    Function MultiByteToWideChar& (ByVal CodePage As _Unsigned Long, Byval dwFlags As _Unsigned Long, Byval lpMultiByteStr As _Offset, Byval cbMultiByte As Long, Byval lpWideCharStr As _Offset, Byval cchWideChar As Long)
End Declare

Function UnicodeToANSI$ (buffer As String)
    Dim As String ansibuffer: ansibuffer = Space$(Len(buffer))
    Dim As Long a: a = WideCharToMultiByte(437, 0, _Offset(buffer), Len(buffer), _Offset(ansibuffer), Len(ansibuffer), 0, 0)
    UnicodeToANSI = Mid$(ansibuffer, 1, InStr(ansibuffer, Chr$(0)) - 1)
End Function

Sub UnicodeToANSI (buffer As String, __dest As String)
    Dim As String ansibuffer: ansibuffer = Space$(Len(buffer))
    Dim As Long a: a = WideCharToMultiByte(437, 0, _Offset(buffer), Len(buffer), _Offset(ansibuffer), Len(ansibuffer), 0, 0)
    __dest = Mid$(ansibuffer, 1, InStr(ansibuffer, Chr$(0)) - 1)
End Sub

Function ANSIToUnicode$ (buffer As String)
    Dim As String unicodebuffer: unicodebuffer = Space$(Len(buffer) * 2)
    Dim As Long a: a = MultiByteToWideChar(65001, 0, _Offset(buffer), Len(buffer), _Offset(unicodebuffer), Len(unicodebuffer))
    ANSIToUnicode = unicodebuffer
End Function

Sub ANSIToUnicode (buffer As String, __dest As String)
    Dim As String unicodebuffer: unicodebuffer = Space$(Len(buffer) * 2)
    Dim As Long a: a = MultiByteToWideChar(65001, 0, _Offset(buffer), Len(buffer), _Offset(unicodebuffer), Len(unicodebuffer))
    __dest = unicodebuffer
End Sub

  

As always, only 64 bit was tested and only 64 bit will be supported.

[SpriggsySpriggs]

Updated original post. Removed authentication logic and fixed a print using issue.

[SpriggsySpriggs]

Special thanks to @DSMan195276 for his help with getting the download rate working on this version. The original post is now updated with this fix.

[SpriggsySpriggs]

Updated original post to add UrlUnescapeA which allows me to decode the URL encoded string and spit out a more friendly filename if HTML escape characters are contained in the path.