[AccessD] Transferring Files via FTP

[David Emerson]

Hi Stuart (and others),

I am working on your code below.  I am initially checking that I can ping to
the server using the InternetOK() function but I am getting an error:
Ping request could not find host sftp://sftp.electricityregistry.co.nz.
Please check the name and try again.

Here is my modified Code (without error coding):

Function InternetOK() As Boolean

    Dim strTemp As String, strExe As String, ff As Long

    strExe = Environ$("COMSPEC")
    strExe = Left$(strExe, Len(strExe) - Len(Dir(strExe)))

    strExe = Environ("COMSPEC") & " /c "
    strExe = strExe & "ping sftp://sftp.electricityregistry.co.nz -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

I am able to connect using FileZilla.  But this includes a login and
password.

Can anyone suggest what I am doing wrong?

Regards

David Emerson
Dalyn Software Ltd
Wellington, New Zealand



-----Original Message-----
From: AccessD <accessd-bounces at databaseadvisors.com> On Behalf Of Stuart
McLachlan
Sent: Wednesday, 6 May 2020 11:42 am
To: Access Developers discussion and problem solving
<accessd at databaseadvisors.com>
Subject: Re: [AccessD] Transferring Files via FTP

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