[AccessD] Transferring Files via FTP
David Emerson
newsgrps at dalyn.co.nz
Fri Oct 9 02:43:41 CDT 2020
Solved that one by using the IP address instead of the server name.
-----Original Message-----
From: AccessD <accessd-bounces at databaseadvisors.com> On Behalf Of David
Emerson
Sent: Friday, 9 October 2020 8:34 pm
To: 'Access Developers discussion and problem solving'
<accessd at databaseadvisors.com>
Subject: Re: [AccessD] Transferring Files via FTP
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
--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com
More information about the AccessD
mailing list