[Vb6] WinInet Asynchronous FTP

[scapula]

Asynchronous Wininet Api (Tested on XP & Seven)
Send Big File on FTP without Application Freez


Exemple To Use:

Código (vb) [Seleccionar] Expandir

'===========================================
'           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

Código (vb) [Seleccionar] Expandir

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

Código (vb) [Seleccionar] Expandir

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

Código (vb) [Seleccionar] Expandir

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