So I wanted to have a nice File Download function with progress indication - I have it working in VC. Just translated it to VB6.
All initializations looks fine - exactly same results as VC.
HOWEVER, executing the recv function causes an immediate colossal crash of IDE.
Here is the code:
All initializations looks fine - exactly same results as VC.
HOWEVER, executing the recv function causes an immediate colossal crash of IDE.
Here is the code:
Code:
Option Explicit
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = 2
Private Const FILE_SHARE_READ = &H1
Private Const AF_INET As Long = 2
Private Const SOCK_STREAM As Long = 1
Private Const IPPROTO_TCP As Long = 6
Private Type SOCKADDR
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 256) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type ADDRINFO
ai_flags As Long ' AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST
ai_family As Long ' PF_xxx
ai_socktype As Long ' SOCK_xxx
ai_protocol As Long ' 0 or IPPROTO_xxx for IPv4 and IPv6
ai_addrlen As Long ' Length of ai_addr
ai_canonname As Long ' Canonical name for nodename
ai_addr As Long ' Binary address
ai_next As Long ' Next structure in linked list
End Type
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long)
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Integer, ByRef lpWSAData As WSADATA) As Long
Private Declare Function gethostbyname Lib "ws2_32.dll" (ByVal name As String) As Long
Private Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal lType As Long, ByVal protocol As Long) As Long
Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal lLen As Long, ByVal flags As Long) As Long
Private Declare Function connect Lib "ws2_32.dll" (ByVal s As Long, ByVal pSockAdr As Long, ByVal namelen As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Private Declare Function send Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal lLen As Long, ByVal flags As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
Private Declare Function getaddrinfo Lib "ws2_32.dll" (ByVal host As String, ByVal ServiceName As Long, ByRef Hints As ADDRINFO, ByRef adr As Long) As Long
Private Declare Sub freeaddrinfo Lib "ws2_32.dll" (ByVal pAdr As Long)
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WriteFile Lib "kernel32.dll" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Dim wsa As WSADATA
Public Sub DownloadStart(ByVal URL As String, Optional ByVal Mode As AsyncReadConstants = vbAsyncReadResynchronize)
vbAsyncReadForceUpdate
End Sub
Function DownloadUrl(sUrl, sFile)
Dim domain As String
Dim p As Long, p2 As Long
Dim pHost As Long
Dim sock As Long
Dim server_addr As SOCKADDR
Dim send_data As String
Dim hFile As Long
Dim bytes_received As Long
Dim buffer() As Byte
Dim host As String
Dim Hints As ADDRINFO, targetAdressInfo As ADDRINFO, pAdrInfo As Long
Dim ret As Long
If wsa.wVersion = 0 Then If WSAStartup(514, wsa) Then DownloadUrl = "Error WSAStartUp": Exit Function
p = InStr(sUrl, "//")
p2 = InStr(p + 2, sUrl, "/")
domain = Mid(sUrl, p + 2, p2 - p - 2)
host = Left(sUrl, p2 - 1)
Hints.ai_family = AF_INET
Hints.ai_protocol = IPPROTO_TCP
Hints.ai_socktype = SOCK_STREAM
ret = getaddrinfo(domain, 0, Hints, pAdrInfo)
If ret <> 0 Or pAdrInfo = 0 Then DownloadUrl = "getaddrinfo": Exit Function
server_addr.sin_family = AF_INET
server_addr.sin_port = htons(80)
GetMem4 pAdrInfo + 24, p
GetMem4 p + 4, server_addr.sin_addr
freeaddrinfo pAdrInfo
sock = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
If sock = -1 Then DownloadUrl = "Error socket": Exit Function
If connect(sock, VarPtr(server_addr), Len(server_addr)) = -1 Then DownloadUrl = "Error connect": closesocket sock: Exit Function
send_data = "GET " & sUrl & " HTTP/1.1" & vbCrLf & "Host: " & host & vbCrLf & "Connection: close" & vbCrLf & vbCrLf
If send(sock, send_data, Len(send_data), 0) = -1 Then DownloadUrl = "Error send": closesocket sock: Exit Function
hFile = CreateFileW(StrPtr(sFile), GENERIC_WRITE, FILE_SHARE_READ, 0, CREATE_ALWAYS, 0, 0)
If hFile = -1 Then DownloadUrl = "Error CreateFile": closesocket sock: Exit Function
ReDim buffer(0 To 1000000)
Do
bytes_received = recv(sock, VarPtr(buffer(0)), 1000000, 0)
If bytes_received = 0 Then Exit Do
If bytes_received < 0 Then DownloadUrl = "receive": Exit Do
WriteFile hFile, VarPtr(buffer(0)), bytes_received, bytes_received, 0
Loop
jClean:
CloseHandle hFile
closesocket sock
End Function