Binaryworld - Performing FTP operation using WinInet APIs ... [ VB -> FTP ]

Step-By-Step Demo

- Create a standard exe project.
- Add one module to the project.
- Add six textbox controls and nine command button controls on the form1. Set MultiLine=True and Scrollbar=Both for Text6.
- add two frame controls and add two radio button controls to each frame.

Form1.frm

Click here to copy the following block

Option Explicit

Dim hOpen As Long, hConnection As Long, hFile As Long
Dim dwType As Long
Dim dwSeman As Long

Const SMALL_FILE = "testsmallupload.txt"
Const BIG_FILE = "testbigupload.txt"

Private Sub ErrorOut(ByVal dwError As Long, ByRef szFunc As String)
  Dim dwRet As Long
  Dim dwTemp As Long
  Dim szString As String * 2048
  Dim szErrorMessage As String

  dwRet = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, _
      GetModuleHandle("wininet.dll"), dwError, 0, _
      szString, 256, 0)
  szErrorMessage = szFunc & " error code: " & dwError & " Message: " & szString
  Debug.Print szErrorMessage
  MsgBox szErrorMessage, , "SimpleFtp"
  If (dwError = 12003) Then
    ' Extended error information was returned
    dwRet = InternetGetLastResponseInfo(dwTemp, szString, 2048)
    Debug.Print szString
    Text6.Text = szString
  End If
End Sub

Sub UpdatePaths()
  Dim pos, filenameonly

  pos = InStr(1, StrReverse(Text4), "\")
  If pos = 0 Then pos = InStr(1, StrReverse(Text4), "/")
  If pos Then filenameonly = Mid(Text4, Len(Text4) - pos + 2, 255)

  pos = InStr(1, StrReverse(Text5), "\")
  If pos = 0 Then pos = InStr(1, StrReverse(Text5), "/")
  If Len(Text5) - pos > 0 Then
    Text5 = Left(Text5, Len(Text5) - pos + 1)
  End If

  If Right(Trim(Text5), 1) = "\" Or Right(Trim(Text5), 1) = "/" Then
    Text5 = Text5 & filenameonly
  Else
    Text5 = Text5 & "/" & filenameonly
  End If
End Sub

Private Sub Command1_Click()
  ''//this will make full upload path (dir+file)
  Call UpdatePaths

  ' for ASCII files use FTP_TRANSFER_TYPE_ASCII
  If (FtpPutFile(hConnection, Text4.Text, Text5.Text, _
      dwType, 0) = False) Then
    ErrorOut Err.LastDllError, "FtpPutFile"
    Exit Sub
  Else
    MsgBox "File transfered!", , "Simple Ftp"
  End If

End Sub

Private Sub Command2_Click()
  If (FtpDeleteFile(hConnection, Text5.Text) = False) Then
    MsgBox "FtpDeleteFile error: " & Err.LastDllError
    Exit Sub
  Else
    MsgBox "File deleted!"
  End If
End Sub

Private Sub Command3_Click()
  If hConnection <> 0 Then
    InternetCloseHandle hConnection
  End If
  hConnection = InternetConnect(hOpen, Text1.Text, INTERNET_INVALID_PORT_NUMBER, _
      Text2.Text, Text3.Text, INTERNET_SERVICE_FTP, dwSeman, 0)
  If hConnection = 0 Then
    ErrorOut Err.LastDllError, "InternetConnect"
    Exit Sub
  Else
    MsgBox "Connected!", , "SimpleFtp"
    Option3.Enabled = False
    Option4.Enabled = False
    Me.Caption = "Connected to " & Text1
  End If

End Sub

Private Sub Command4_Click()
  '&H40000000 == GENERIC_WRITE
  Const BLOCK_SIZE = 1024 '//1024 Bytes
  Dim Data() As Byte    ' array of 100 elements 0 to 99
  Dim Written As Long
  Dim Size As Long
  Dim Sum As Long
  Dim j As Long
  Dim ub As Long, ptr As Long, BS As Long

  ''//this will make full upload path (dir+file)
  Call UpdatePaths

  Sum = 0
  j = 0
  ' for ASCII files use FTP_TRANSFER_TYPE_ASCII
  hFile = FtpOpenFile(hConnection, Text5.Text, &H40000000, dwType, 0)
  If hFile = 0 Then
    ErrorOut Err.LastDllError, "FtpOpenFile"
    Exit Sub
  End If

  Open Text4.Text For Binary Access Read As #1
  Size = LOF(1)

  ReDim Data(0 To LOF(1)) As Byte

  Get #1, , Data()
  On Error Resume Next
  ptr = 0
  ub = UBound(Data)
  If Err.Number = 0 Then
    Do While (ptr <= ub)
      If ptr + BLOCK_SIZE <= ub + 1 Then
        BS = BLOCK_SIZE  '//Full block size
      Else
        BS = (ub - ptr)  '//Only remaining bytes
      End If

      If (InternetWriteFile(hFile, Data(ptr), BS, Written) = 0) Then
        ErrorOut Err.LastDllError, "InternetWriteFile"
        Exit Sub
      End If
      DoEvents
      ptr = ptr + BS
      Me.Caption = Str(ptr) & " Bytes transferred"
    Loop
  Else
    MsgBox Err.Description
  End If

  Close #1
  InternetCloseHandle (hFile)
End Sub

Private Sub Command5_Click()
  ' for ASCII files use FTP_TRANSFER_TYPE_ASCII
  ' add INTERNET_FLAG_NO_CACHE_WRITE to avoid local caching 0x04000000 (hex)
  If (FtpGetFile(hConnection, Text5.Text, Text4.Text, False, _
      FILE_ATTRIBUTE_NORMAL, dwType Or INTERNET_FLAG_RELOAD, 0) = False) Then
    ErrorOut Err.LastDllError, "FtpPutFile"
    Exit Sub
  Else
    MsgBox "File transfered!", , "SimpleFtp"
  End If
End Sub

Private Sub Command6_Click()
  Dim szDir As String

  szDir = String(1024, Chr$(0))

  If (FtpGetCurrentDirectory(hConnection, szDir, 1024) = False) Then
    ErrorOut Err.LastDllError, "FtpGetCurrentDirectory"
    Exit Sub
  Else
    MsgBox "Current directory is: " & szDir, , "SimpleFtp"
  End If
End Sub

Private Sub Command7_Click()
  If (FtpSetCurrentDirectory(hConnection, Text5.Text) = False) Then
    ErrorOut Err.LastDllError, "FtpSetCurrentDirectory"
    Exit Sub
  Else
    MsgBox "Directory is changed to " & Text5.Text, , "SimpleFtp"
  End If
End Sub

Private Sub Command8_Click()
  Dim szDir As String
  Dim hFind As Long
  Dim nLastError As Long
  Dim dError As Long
  Dim ptr As Long
  Dim pData As WIN32_FIND_DATA

  hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
  nLastError = Err.LastDllError
  If hFind = 0 Then
    If (nLastError = ERROR_NO_MORE_FILES) Then
      MsgBox "This directory is empty!", , "SimpleFtp"
    Else
      ErrorOut Err.LastDllError, "FtpFindFirstFile"
    End If
    Exit Sub
  End If

  dError = NO_ERROR
  Dim bRet As Boolean

  szDir = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1) & " " & Win32ToVbTime(pData.ftLastWriteTime)
  szDir = szDir & vbCrLf
  Do
    pData.cFileName = String(MAX_PATH, 0)
    bRet = InternetFindNextFile(hFind, pData)
    If Not bRet Then
      dError = Err.LastDllError
      If dError = ERROR_NO_MORE_FILES Then
        Exit Do
      Else
        ErrorOut Err.LastDllError, "InternetFindNextFile"
        InternetCloseHandle (hFind)
        Exit Sub
      End If
    Else

      szDir = szDir & Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1) & " " & Win32ToVbTime(pData.ftLastWriteTime) & vbCrLf
    End If
  Loop

  Dim szTemp As String
  szTemp = String(1024, Chr$(0))
  If (FtpGetCurrentDirectory(hConnection, szTemp, 1024) = False) Then
    ErrorOut Err.LastDllError, "FtpGetCurrentDirectory"
    Exit Sub
  End If
  MsgBox szDir, , "Directory Listing of: " & szTemp
  InternetCloseHandle (hFind)
End Sub

Private Sub Command9_Click()
  If hConnection <> 0 Then
    InternetCloseHandle hConnection
  End If
  hConnection = 0
  MsgBox "Disconnected.", , "SimpleFtp"
  Me.Caption = "Not Connected"
End Sub

Private Sub Form_Load()
  Me.Caption = "Not Connected"
  Command1.Caption = "Put File"
  Command2.Caption = "Delete File"
  Command3.Caption = "Connect"
  Command4.Caption = "Put Large"
  Command5.Caption = "Get File"
  Command6.Caption = "Get Current Dir"
  Command7.Caption = "Set Dir"
  Command8.Caption = "Dir"
  Command9.Caption = "Disconnect"
  Option1.Caption = "ASCII"
  Option2.Caption = "Binary"
  Option3.Caption = "Active (Default)"
  Option4.Caption = "Passive"

  Call CreateSampleFiles

  Text1.Text = "ftp.binaryworld.net"
  'Text1.Text = "ftp.microsoft.com"

  Text2.Text = "anonymous"
  Text3.Text = "mypassword" '//This password will be ignored for "Anonymous" user
  Text4.Text = App.Path & "\" & SMALL_FILE

  Text5.Text = "/Upload"
  'Text5.Text = "/KBHelp"

  hOpen = InternetOpen("My VB Test", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
  If hOpen = 0 Then
    ErrorOut Err.LastDllError, "InternetOpen"
    Unload Form1
  End If

  dwType = FTP_TRANSFER_TYPE_ASCII
  dwSeman = 0
  hConnection = 0

  Command3_Click      '//Connect

  'FtpCreateDirectory hConnection, "testdir"
  'FtpRemoveDirectory hConnection, "testdir"

  Command7_Click      '//Set dir
End Sub

Private Sub Form_Unload(Cancel As Integer)
  On Error Resume Next
  If hConnection <> 0 Then InternetCloseHandle hConnection
  If hOpen <> 0 Then InternetCloseHandle hOpen

  Kill App.Path & "\" & SMALL_FILE
  Kill App.Path & "\" & BIG_FILE
  End           '//End now
End Sub

Sub CreateSampleFiles()

  Dim hFile As Long, i As Long
  hFile = FreeFile
  Open App.Path & "\" & SMALL_FILE For Output As #hFile
  Print #hFile, "Hello ftp world"
  Close #hFile

  hFile = FreeFile
  Open App.Path & "\" & BIG_FILE For Output As #hFile
  For i = 1 To 10000
    Print #hFile, "Hello ftp world" & vbCrLf
  Next
  Close #hFile

  MsgBox "Two files created for demo" & vbCrLf & _
      App.Path & "\" & SMALL_FILE & " (" & FileLen(App.Path & "\" & SMALL_FILE) & " Bytes)" & vbCrLf & _
      App.Path & "\" & BIG_FILE & " (" & FileLen(App.Path & "\" & BIG_FILE) & " Bytes)"

End Sub

Private Sub Option1_Click()
  dwType = FTP_TRANSFER_TYPE_ASCII
End Sub

Private Sub Option2_Click()
  dwType = FTP_TRANSFER_TYPE_BINARY
End Sub

Private Sub Option3_Click()
  dwSeman = 0
End Sub

Private Sub Option4_Click()
  dwSeman = INTERNET_FLAG_PASSIVE
End Sub

Module1.bas

Click here to copy the following block

Option Explicit
Public Const MAX_PATH = 260
Public Const INTERNET_FLAG_RELOAD = &H80000000
Public Const NO_ERROR = 0
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
Public Const FILE_ATTRIBUTE_OFFLINE = &H1000
Public Const INTERNET_FLAG_PASSIVE = &H8000000
Public Const FORMAT_MESSAGE_FROM_HMODULE = &H800

Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As Currency
  ftLastAccessTime As Currency
  ftLastWriteTime As Currency
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

Public Const ERROR_NO_MORE_FILES = 18

Public Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
    (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long

Public Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
    (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _
    lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long

Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As Any, lpLocalFileTime As Any) As Long

Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Public Const INTERNET_INVALID_PORT_NUMBER = 0
Public Const INTERNET_SERVICE_FTP = 1
Public Const FTP_TRANSFER_TYPE_BINARY = &H2
Public Const FTP_TRANSFER_TYPE_ASCII = &H1

Public Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
    (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

Public Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" _
    (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Boolean

Public Declare Function InternetWriteFile Lib "wininet.dll" _
    (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToWite As Long, _
    dwNumberOfBytesWritten As Long) As Integer

Public Declare Function FtpOpenFile Lib "wininet.dll" Alias "FtpOpenFileA" _
    (ByVal hFtpSession As Long, ByVal sBuff As String, ByVal Access As Long, ByVal Flags As Long, ByVal Context As Long) As Long

Public Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
    (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
    ByVal lpszRemoteFile As String, _
    ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

Public Declare Sub FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" ( _
    ByRef hConnect As Long, _
    ByVal lpszDirectory As String)

Public Declare Sub FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" ( _
    ByRef hConnect As Long, _
    ByVal lpszDirectory As String)

Public Declare Function FtpDeleteFile Lib "wininet.dll" _
    Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, _
    ByVal lpszFileName As String) As Boolean
Public Declare Function InternetCloseHandle Lib "wininet.dll" _
    (ByVal hInet As Long) As Long

Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
    (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
    ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Public Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
    (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _
    ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, _
    ByVal lFlags As Long, ByVal lContext As Long) As Long

Public Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
    (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
    ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
    ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

Const rDayZeroBias As Double = 109205#  ' Abs(CDbl(#01-01-1601#))
Const rMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

Declare Function InternetGetLastResponseInfo Lib "wininet.dll" _
    Alias "InternetGetLastResponseInfoA" _
    (ByRef lpdwError As Long, _
    ByVal lpszErrorBuffer As String, _
    ByRef lpdwErrorBufferLength As Long) As Boolean

Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
    (ByVal dwFlags As Long, ByVal lpSource As Long, ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, _
    Arguments As Long) As Long

Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpLibFileName As String) As Long

Function Win32ToVbTime(ft As Currency) As Date
  Dim ftl As Currency
  ' Call API to convert from UTC time to local time
  If FileTimeToLocalFileTime(ft, ftl) Then

    ' Local time is nanoseconds since 01-01-1601
    ' In Currency that comes out as milliseconds
    ' Divide by milliseconds per day to get days since 1601
    ' Subtract days from 1601 to 1899 to get VB Date equivalent

    Win32ToVbTime = CDate((ftl / rMillisecondPerDay) - rDayZeroBias)

  Else
    MsgBox Err.LastDllError
  End If

End Function