Asynchronous Wininet Api (Tested on XP & Seven)
Send Big File on FTP without Application Freez
Exemple To Use:
'===========================================
' WinInet Async CallBack
'===========================================
' Author: (Erik L)
' Init. (EGL)
' Email: egl1044@gmail.com
'
'===========================================
Dim IWnet As New WinInetAsync
Private Sub Form_Load()
IWnet.Server = "" ' FTP
IWnet.UserName = "" ' USER
IWnet.Password = "" ' PASS
Call IWnet.Connect(True) 'True = ACTIVE ASYNCHRONOUS
Call IWnet.FtpDirectoryCreate(Environ$("Computername"))
Call IWnet.FtpSetDirectory(Environ$("Computername"))
Call IWnet.FtpUpload("Calc.exe", Environ$("WINDIR") & "\SYSTEM32\calc.exe", FTP_TRANSFER_TYPE_BINARY)
Call IWnet.Disconnect
End Sub
Module: CallBackProc.BAS
Option Explicit
Private Declare Sub BalanceMemoryAny Lib "kernel32" Alias "RtlMoveMemory" ( _
lpDest As Any, _
lpSource As Any, _
ByVal nBytes As Long)
Public Enum InternetStatusVals
ResolvingName = 10
NameResolved = 11
ConnectingToServer = 20
ConnectedToServer = 21
SendingRequest = 30
RequestSent = 31
ReceivingResponse = 40
ResponseReceived = 41
PreFetch = 43
ClosingConnection = 50
ConnectionClosed = 51
HandleCreated = 60
HandleClosing = 70
DetectingProxy = 80
RequestComplete = 100
Redirecting = 110
IntermediateResponse = 120
UserInputRequired = 140
StateChange = 200
End Enum
Private mIAR As INERNET_ASYNC_RESULT
Public Sub INTERNET_STATUS_CALLBACK( _
ByVal hInternet As Long, _
ByVal dwContext As Long, _
ByVal dwInternetStatus As InternetStatusVals, _
ByVal lpvStatusInformation As Long, _
ByVal dwStatusInformationLength As Long)
Dim dwRead As Long
Dim cBuffer As String
cBuffer = Space$(dwStatusInformationLength)
Select Case dwInternetStatus
Case ResolvingName
BalanceMemoryAny ByVal cBuffer, ByVal lpvStatusInformation, dwStatusInformationLength
Debug.Print RipNulls(cBuffer)
Case NameResolved
BalanceMemoryAny ByVal cBuffer, ByVal lpvStatusInformation, dwStatusInformationLength
Debug.Print RipNulls(cBuffer)
Case ConnectingToServer
Debug.Print "Connecting"
Case ConnectedToServer
Debug.Print "Connected"
Case SendingRequest
Case RequestSent
BalanceMemoryAny dwRead, ByVal lpvStatusInformation, dwStatusInformationLength
Case ReceivingResponse
Case ResponseReceived
Case ClosingConnection
Debug.Print "Closing Connection"
Case ConnectionClosed
Debug.Print "Closed Connection"
Case HandleCreated
BalanceMemoryAny mIAR.dwAddress, ByVal lpvStatusInformation, dwStatusInformationLength
Case HandleClosing
Case UserInputRequired
Debug.Print "User Input"
Case RequestComplete
Debug.Print "Request Complete"
Case Else
End Select
DoEvents
End Sub
Public Function ReturnAddress() As Long
ReturnAddress = mIAR.dwAddress
End Function
Module: mInet.BAS
Option Explicit
Public Type INERNET_ASYNC_RESULT
dwResult As Long
dwError As Long
dwAddress As Long 'Address Handle created by callback
End Type
Public Declare Function InternetOpenA Lib "WININET.DLL" ( _
ByVal lpszAgent As String, _
ByVal dwAccessType As Long, _
ByVal lpszProxyName As String, _
ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Public Declare Function InternetSetStatusCallback Lib "WININET.DLL" ( _
ByVal hInternet As Long, _
ByVal lpfnInternetCallback As Long) As Long
Public Declare Function InternetConnectA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszServerName As String, _
ByVal nServerPort As Long, _
ByVal lpszUsername As String, _
ByVal lpszPassword As String, _
ByVal dwService As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function InternetReadFile Lib "WININET.DLL" ( _
ByVal hFile As Long, _
ByVal sBuffer As Long, _
ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Long
Public Declare Function InternetOpenUrl Lib "WININET.DLL" Alias "InternetOpenUrlA" ( _
ByVal hInternet As Long, _
ByVal lpszUrl As String, _
lpszHeaders As Any, _
ByVal dwHeadersLength As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function InternetQueryDataAvailable Lib "WININET.DLL" ( _
ByVal hFile As Long, _
lpdwNumberOfBytesAvailable As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Public Declare Function InternetCloseHandle Lib "WININET.DLL" ( _
ByVal hInternet As Long) As Long
Public Declare Function SleepEx Lib "kernel32" ( _
ByVal dwMilliseconds As Long, _
ByVal bAlertable As Long) As Long
Public Declare Function WriteFile Lib "kernel32" ( _
ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Any) As Long
Public mOpen As Long '// InternetOpen Handle
Public mConn As Long '// InternetConnect Handle
Public Function RipNulls(ByVal AnyBuffer As String) As String
RipNulls = Left$(AnyBuffer, InStr(AnyBuffer, vbNullChar) - 1)
End Function
Class: WinInetAsync.CLS
Option Explicit
Option Base 0
'FTP Const
Private Const FTP_RELOADS& = &H80000000
Private Const FTP_PASSIVE& = &H8000000
Private Const FTP_SERVICE& = 1
Private Const FTP_PORTNUM& = 21
Private Const FTP_DIRECT& = 1
Private Const FTP_READ& = &H80000000
Private Const FTP_ASYNC& = &H1
'HTTP Const
Private Const HTTP_ASYNC& = &H1
Private Const HTTP_NO_CACHE_WRITE& = &H4000000
Private Const HTTP_RESYNCHRONIZE& = &H800
Private Const HTTP_DIRECT = 1
'CreateFile,WriteFile Const
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_GENERIC_WRITE = &H40000000
Private Const FILE_CREATE_ALWAYS = 2
'Other Const
Private Const DW_CONTEXT& = 2
Private Const INVALID_CALLBACK& = -1
Private Const MAX_PATH As String = 260
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
ByVal lpFileName As String, _
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
'FtpGetFile:
' Retrieves a file from the FTP serverand stores
' it under the specified file name, creating a
' new local file in the process.
Private Declare Function FtpGetFile Lib "WININET.DLL" Alias "FtpGetFileA" ( _
ByVal hConnect As Long, _
ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
'FtpPutFile:
' Stores a file on the FTP server
Private Declare Function FtpPutFileA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
'FtpSetCurrentDirectory:
' Changes to a different working directory on the FTP server.
Private Declare Function FtpSetCurrentDirectoryA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Long
'FtpGetCurrentDirectory:
' Retrieves the current directory for the specified FTP session.
Private Declare Function FtpGetCurrentDirectoryA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszCurrentDirectory As String, _
ByRef lpdwCurrentDirectory As Long) As Long
'FtpOpenFile:
' Initiates access to a remote file on an FTP server for reading or writing.
Private Declare Function FtpOpenFile Lib "WININET.DLL" Alias "FtpOpenFileA" ( _
ByVal hConnect As Long, _
ByVal lpszFileName As String, _
ByVal dwAccess As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
'FtpGetFileSize:
' Returns FileSize on FTP server
Private Declare Function FtpGetFileSize Lib "WININET.DLL" ( _
ByVal hFile As Long, _
ByRef lpdwFileSizeHigh As Long) As Long
'FtpDeleteFile:
' Deletes a file stored on the FTP server.
Private Declare Function FtpDeleteFileA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszFileName As String) As Long
'FtpCreateDirectory:
' Creates a new directory on the FTP server.
Private Declare Function FtpCreateDirectoryA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Long
'FtpRemoveDirectory
' Removes the specified directory on the FTP server.
Private Declare Function FtpRemoveDirectory Lib "WININET.DLL" Alias "FtpRemoveDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Long
'FtpRenameFile
' Renames a file stored on the FTP server.
Private Declare Function FtpRenameFileA Lib "WININET.DLL" ( _
ByVal hConnect As Long, _
ByVal lpszExisting As String, _
ByVal lpNewFileName As String) As Long
Public Enum TransferTypes
FTP_TRANSFER_TYPE_UNKNOWN = &H0
FTP_TRANSFER_TYPE_ASCII = &H1
FTP_TRANSFER_TYPE_BINARY = &H2
End Enum
Public Server$ '// Ftp Servername
Public UserName$ '// Ftp Username
Public Password$ '// Ftp Password
Public AmIRegistered$
Private m_AsyncResult As INERNET_ASYNC_RESULT
Public Sub Connect(Optional AsyncMode As Boolean = True)
Dim Result As Long
mOpen = InternetOpenA( _
App.ProductName, _
FTP_DIRECT, _
vbNullString, _
vbNullString, _
FTP_ASYNC&)
If AsyncMode = True Then
Result = InternetSetStatusCallback(mOpen, AddressOf INTERNET_STATUS_CALLBACK)
End If
mConn = InternetConnectA( _
mOpen, _
Server, _
FTP_PORTNUM&, _
UserName, _
Password, _
FTP_SERVICE&, _
FTP_PASSIVE&, DW_CONTEXT&)
End Sub
Public Function Disconnect() As Boolean
'Clean up
Call InternetCloseHandle(mConn)
Call InternetCloseHandle(mOpen)
Call InternetCloseHandle(ReturnAddress)
End Function
Public Function FtpDownload(ByVal RemoteFile As String, _
ByVal LocalFile As String, _
ByVal TransferMode As TransferTypes) As Boolean
Dim Success As Boolean
Success = FtpGetFile(mConn, _
RemoteFile, _
LocalFile, _
False, ByVal 0&, _
TransferMode, DW_CONTEXT&)
FtpDownload = Success
End Function
Public Function FtpUpload(ByVal RemoteFile As String, _
ByVal LocalFile As String, _
ByVal TransferMode As TransferTypes) As Boolean
Dim Success As Boolean
Success = FtpPutFileA(mConn, _
LocalFile, _
RemoteFile, _
TransferMode, DW_CONTEXT&)
FtpUpload = Success
End Function
Public Function FtpGetDirectory() As String
Dim DirBuff As String
Dim strTemp As String
Dim Success As Boolean
DirBuff = String$(MAX_PATH, vbNullChar)
Success = FtpGetCurrentDirectoryA(mConn, DirBuff, Len(DirBuff))
FtpGetDirectory = RipNulls(DirBuff)
End Function
Friend Function FtpSetDirectory(ByVal SSetDir As String) As Boolean
Dim Success As Boolean
Success = FtpSetCurrentDirectoryA(mConn, SSetDir)
FtpSetDirectory = Success
End Function
Friend Function FtpFileDelete(ByVal sFileName As String) As Boolean
Dim Success As Boolean
Success = FtpDeleteFileA(mConn, sFileName)
FtpFileDelete = Success
End Function
Friend Function FtpFileRename(ByVal ExistingFileName As String, _
ByVal RenameFile As String) As Boolean
Dim Success As Boolean
Success = FtpRenameFileA(mConn, ExistingFileName, RenameFile)
FtpFileRename = Success
End Function
Friend Function FtpDirectoryCreate(ByVal CreateNewDirName As String) As Boolean
Dim Success As Boolean
Success = FtpCreateDirectoryA(mConn, CreateNewDirName)
FtpDirectoryCreate = Success
End Function
Friend Function FtpDirectoryRemove(ByVal RemoveDirectoryName As String) As Boolean
Dim Success As Boolean
Success = FtpRemoveDirectory(mConn, RemoveDirectoryName)
FtpDirectoryRemove = Success
End Function
Public Function Http_DownloadFile(ByVal FileName As String, _
ByVal WebURL As String, _
ByVal TransferMode As TransferTypes, _
Optional ChunkSize As Long = 8192)
Dim hLocalFile As Long
Dim Buffer() As Byte
Dim bytesRead As Long
Dim bytesWritten As Long
Dim bytesTransferred As Long
Dim boolCancel As Boolean
Dim lOpen As Long
Dim lHandle As Long
Dim Result As Long
lOpen = InternetOpenA(App.ProductName, _
HTTP_DIRECT, _
vbNullString, _
vbNullString, _
HTTP_ASYNC&)
Result = InternetSetStatusCallback(lOpen, AddressOf INTERNET_STATUS_CALLBACK)
lHandle = InternetOpenUrl(lOpen, _
WebURL, _
vbNullString, _
ByVal 0&, _
TransferMode, _
HTTP_NO_CACHE_WRITE& Or HTTP_RESYNCHRONIZE&)
hLocalFile = CreateFile(FileName, _
FILE_GENERIC_WRITE, _
FILE_SHARE_WRITE, _
ByVal 0&, FILE_CREATE_ALWAYS, 0, 0)
If hLocalFile <> 0 Then
ReDim Buffer(ChunkSize)
Do
If InternetReadFile(lHandle, _
ByVal VarPtr(Buffer(0)), _
ChunkSize, _
bytesRead) Then
If WriteFile(hLocalFile, _
ByVal VarPtr(Buffer(0)), _
bytesRead, _
bytesWritten, _
ByVal 0&) Then
bytesTransferred = bytesTransferred + bytesWritten
End If
Else
boolCancel = True
End If
DoEvents
Loop While bytesRead = ChunkSize And Not boolCancel
End If
Call CloseHandle(hLocalFile)
Call InternetCloseHandle(lHandle)
Call InternetCloseHandle(lOpen)
End Function