[AccessD] Transferring Files via FTP

[Stuart McLachlan]

Heres' a  modFTP from an old application of mine which uses the built in Windows FTP client 
and an FTP script generated "on the fly".  It will need PTRSAFE, LONGPTR etc modifications 
for Officer 64bit.

(These days, I  SHELL to my own applicationa written in PowerBASIC  for all FPT processes)


Option Explicit
Option Compare Database

Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

Public g_strFTPPutList() As String

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type

Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal 
dwMilliseconds As Long) As Long

Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal 
lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As 
Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment 
As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, 
lpProcessInformation As PROCESS_INFORMATION) As Long

Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
On Error GoTo Err_Handler

   Dim proc As PROCESS_INFORMATION
   Dim start As STARTUPINFO
   Dim ret As Long
   
   ' Initialize the STARTUPINFO structure:
   With start
      .cb = Len(start)
      If Not IsMissing(WindowStyle) Then
         .dwFlags = STARTF_USESHOWWINDOW
         .wShowWindow = WindowStyle
      End If
   End With
   ' Start the shelled application:
   ret& = CreateProcessA(0&, Pathname, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, 
start, proc)
   ' Wait for the shelled application to finish:
   ret& = WaitForSingleObject(proc.hProcess, INFINITE)
   ret& = CloseHandle(proc.hProcess)

Exit_Here:
   Exit Sub
Err_Handler:
   MsgBox Err.Description, vbExclamation, "E R R O R"
   Resume Exit_Here
    
End Sub


'Following functions look for Site, Login, PW in table usysWeb
Function ListFTPFiles(Directory As String) As Variant
Const q As String * 1 = """"
Dim sEXE As String
Dim strList As String
Dim strFIles() As String
Dim x As Long
Dim ff As Long
strList = TempDir() & "FTPCmds.tmp"
ff = FreeFile
Open strList For Output As #ff
Print #ff, "open " & DLookup("Site", "usysWEB")
Print #ff, DLookup("Login", "usysWEB")
Print #ff, DLookup("PW", "usysWEB")
Print #ff, "cd " & Directory
Print #ff, "ls . " & TempDir() & "\" & "webfiles.txt"
Print #ff, "bye"
Close #ff
sEXE = Environ$("COMSPEC")
sEXE = Left$(sEXE, Len(sEXE) - Len(Dir(sEXE)))
sEXE = sEXE & "ftp.exe -s:" & q & strList & q
ShellWait sEXE, vbHide
Kill strList
ff = FreeFile
Open TempDir() & "webfiles.txt" For Input As #ff
While Not EOF(ff)
   x = x + 1
   ReDim Preserve strFIles(x)
   Line Input #1, strFIles(x)
Wend
Close #ff
'Kill TempDir() & "webfiles.txt"
ListFTPFiles = strFIles()
End Function

Function FTPPut(Directory As String, Filename As String) As Boolean
Const q As String * 1 = """"
Dim strExe As String
Dim strLocalDir As String
Dim strFName As String
Dim strList As String
Dim ff As Long
If Dir(Filename) = "" Then
   MsgBox Filename & " not found!"
   Exit Function
End If
strLocalDir = Left$(Filename, InStrRev(Filename, "\") - 1)
If Len(strLocalDir) = 2 Then strLocalDir = strLocalDir & "\"
strFName = Mid$(Filename, InStrRev(Filename, "\") + 1)
strList = TempDir() & "FTPCmds.tmp"
ff = FreeFile
Open strList For Output As #ff
Print #ff, "open " & DLookup("Site", "usysWEB")
Print #ff, DLookup("Login", "usysWEB")
Print #ff, DLookup("PW", "usysWEB")
Print #ff, "cd " & Directory
Print #ff, "lcd " & q & strLocalDir & q
Print #ff, "binary"
Print #ff, "put " & q & strFName & q
Print #ff, "bye"
Close #ff
strExe = Environ$("COMSPEC")
strExe = Left$(strExe, Len(strExe) - Len(Dir(strExe)))
strExe = strExe & "ftp.exe -s:" & q & strList & q
ShellWait strExe, vbHide 'vbNormalFocus
'Kill strList
End Function

Function FTPGet(Filename As String, LocalDirectory As String) As Boolean
Const q As String * 1 = """"
Dim strExe As String
Dim strFTPDir As String
Dim strFName As String
Dim strList As String
Dim ff As Long
If Dir(LocalDirectory, vbDirectory) = "" Then
   MsgBox LocalDirectory & " not found"
   Exit Function
End If
strFTPDir = Left$(Filename, InStrRev(Filename, "/"))
strFName = Mid$(Filename, InStrRev(Filename, "/") + 1)
strList = TempDir() & "FTPCmds.tmp"
ff = FreeFile
Open strList For Output As #ff
Print #ff, "open " & DLookup("Site", "usysWEB")
Print #ff, DLookup("Login", "usysWEB")
Print #ff, DLookup("PW", "usysWEB")
Print #ff, "cd " & strFTPDir
Print #ff, "lcd " & LocalDirectory
Print #ff, "binary"
Print #ff, "get " & q & strFName & q
Print #ff, "bye"
Close #ff
strExe = Environ$("COMSPEC")
strExe = Left$(strExe, Len(strExe) - Len(Dir(strExe)))
strExe = strExe & "ftp.exe -s:" & q & strList & q
ShellWait strExe, vbHide
Kill strList
End Function

Function InternetOK() As Boolean
Dim strTemp As String
Dim strExe As String
Dim ff As Long
strExe = Environ$("COMSPEC")
strExe = Left$(strExe, Len(strExe) - Len(Dir(strExe)))

strExe = Environ("COMSPEC") & " /c "
strExe = strExe & "ping " & DLookup("Site", "usysWEB") & " -n 1 > """ & TempDir() & 
"pingtest.txt"""
ShellWait strExe, vbHide
'Debug.Print strExe
ff = FreeFile
Open TempDir() & "pingtest.txt" For Input As #ff
Line Input #ff, strTemp
Close #ff
If InStr(strTemp, "Ping request could not find host") > 0 Then
   InternetOK = False
Else
   InternetOK = True
End If
 
End Function

Function FTPPutList(FileList() As String) As Boolean
'FileList Array is 0 based Row(0) is blank.
' Subsequent rows formatted as:  RemoteDir[Tab]LocalDir[Tab]Filename[Tab]
Const q As String * 1 = """"
Dim strExe As String
Dim strLocalDir As String
Dim strRemoteDir As String
Dim strLocalDirStore As String
Dim strRemoteDirStore As String
Dim strFileName As String
Dim strList As String
Dim strCmds As String
Dim ff As Long
Dim x As Long
Dim strPut() As String
strCmds = TempDir() & "FTPCmds.tmp"
ff = FreeFile
Open strCmds For Output As #ff
Print #ff, "open " & DLookup("Site", "usysWEB")
Print #ff, DLookup("Login", "usysWEB")
Print #ff, DLookup("PW", "usysWEB")
Print #ff, "binary"

For x = 1 To UBound(FileList())
    strPut() = Split(FileList(x), Chr$(9))
    strRemoteDir = strPut(0)
    strLocalDir = strPut(1)
    strFileName = strPut(2)
    
    If strRemoteDir <> strRemoteDirStore Then
       Print #ff, "cd " & strRemoteDir
       strRemoteDirStore = strRemoteDir
    End If
    
    If strLocalDir <> strLocalDirStore Then
       Print #ff, "lcd " & strLocalDir
       strLocalDirStore = strLocalDir
    End If
    
    If Dir(strLocalDir & strFileName) = "" Then
       MsgBox strLocalDir & strFileName & " not found!"
       Exit Function
    End If
    
    Print #ff, "put " & q & strFileName & q
Next
Print #ff, "bye"
Close #ff
strExe = Environ$("COMSPEC")
strExe = Left$(strExe, Len(strExe) - Len(Dir(strExe)))
strExe = strExe & "ftp.exe -s:" & q & strList & q
ShellWait strExe, vbHide 'vbNormalFocus
End Function
---------------------- END OF modFTP

modFTP also uses this 

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
 (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Public Function TempDir() As String
Dim strPath As String
 strPath = Space(MAX_PATH)
 GetTempPath Len(strPath), strPath
  TempDir = Left(strPath, InStr(1, strPath, vbNullChar) - 1)
End Function



On 6 May 2020 at 11:07, David Emerson wrote:

> Hi Listers,
> 
> 
> 
> I hope everyone is keeping safe.
> 
> 
> 
> Can anyone give me recommendations for code/software so that I can log
> into a secure FTP site using a username and password, and  upload and
> download files via vba?
> 
> 
> 
> Regards
> 
> David Emerson
> Dalyn Software Ltd
> Wellington, New Zealand
> 
> 
> 
> 
> 
> 
> 
> 
> 
> -- 
> AccessD mailing list
> AccessD at databaseadvisors.com
> http://databaseadvisors.com/mailman/listinfo/accessd
> Website: http://www.databaseadvisors.com
>