NEW URL Downloader (WinHTTP) - Printable Version

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