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

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
 

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
 

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