Solved

FTP Download Using VBA

Posted on 2014-12-13
7
1,426 Views
Last Modified: 2014-12-16
I need some code to download a file using FTP.  I need to visit a site, Download a file there and save that download file to a directory on my computer.   I also need some mechanism to tell me if the code failed and what the failure was (connection,missing file, wrong directory).  The module runs without showing me an error but nothing else happens.  I have searched the entire computer and cannot find the file "Test3.txt".  Here is my data; the code I am trying to use is shown below

Each of the variables below will be chosen using DLOOKUP from a table (this part is easy)
   local Folder=c:\juricta\OLCC - where to store the downloaded FTP file
   localFileName=inventory.txt - name I want downloaded file to be called on my computer
   ftpFolder=Liquor (1 sub-directory below root for site)(FULL folder=www.randdcomputers.com/Liquor)
   ftpFileName=Test3.txt
   ftpSite=www.randdcomputers.com  (FILE WANTED is in www.randdcomputers.com/Liquor)
   ftpUserName=juricta
   ftpPassword=Dltbgyd!982

*********************************
Code Used
*********************************

    'CODE for download
    ' Shell variant
    ' Requires reference to Microsoft Shell Controls and Automation
    Dim myShell As Shell32.Shell
    Dim localFolder As Shell32.Folder ' folder on PC
    Dim ftpFolder As Shell32.Folder

    Set myShell = New Shell
    Set localFolder = myShell.NameSpace("C:\juricta\OLCC")
    Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor/")
   
    localFolder.CopyHere ftpFolder.Items.Item("Test3.txt")
   
Anyone have either an explanation or BETTER yet, and easier way to do this??
0
Comment
Question by:juricta
  • 3
  • 2
  • 2
7 Comments
 
LVL 18

Expert Comment

by:SimonAdept
Comment Utility
Hi, I have used FTP batch scripts to do this, but I haven't got a working example in front of me.
General principle is to write the script in vba then shell out to get command line FTP to run the the script and return focus to your procedure when complete.
I can give you a working example on Monday, but in the meantime you can Google the subject. Other experts may well have something closer to hand?
0
 
LVL 26

Expert Comment

by:Nick67
Comment Utility
I do the same as @SimonAdept.  I compose a command and answer file in VBA and use Shell to execute them from the command line.  Your code look intriguing.  But Monday is the soonest I can manage
0
 

Author Comment

by:juricta
Comment Utility
I can wait unitl Monday but am still here if anyone else has an answer.  All of this needs to be done from an Access 2010 database.  The client is not very computer literate and needs to do as little as possible to make this happen
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 18

Accepted Solution

by:
SimonAdept earned 250 total points
Comment Utility
Here's the code I used to use. If I was to re-write it now, I'd do away with the module-level variables, but it works as is. Just re-tested this morning.

2 modules
Option Compare Database
Option Explicit

'Declare module-scope variables to store IP addresses and server names
Dim FTPServerIP As String
Dim FTPUsername As String
Dim FTPPassword As String
Dim FTPDirectory As String
Dim LocalDirectory As String
Dim ServerCode As String



Sub main()
Dim rs As DAO.Recordset
    ServerCode = "ABC" 'set module-level variable for server (normally from combo box on form)
    Set rs = CurrentDb.OpenRecordset("select * from tblConfig where FTP_server_name ='" & ServerCode & "'")
    'Provided recordset not empty, populate module-level variables from it
    If Not (rs.BOF And rs.EOF) Then
        FTPServerIP = rs!FTP_SERVER_IP
        FTPUsername = rs!FTP_USERNAME
        FTPPassword = rs!FTP_PASSWORD
        FTPDirectory = rs!FTP_Directory
        LocalDirectory = rs!FTP_LocalDirectory
        rs.Close
    Else
        rs.Close
        Err.Raise vbObjectError + 1, "Extract-FTP", "No FTP config found for " & ServerCode
    End If

    'Run subroutine to create FTP script and execute it
    Call GetDataFromFTPServer
End Sub

Sub GetDataFromFTPServer()
'Delete any existing print, batch and FTP script files.
On Error Resume Next
    Kill LocalDirectory & "ptr99.txt"
    Kill LocalDirectory & "ptr99.dat"
    Kill LocalDirectory & "ptr99.bat"
On Error GoTo 0
CreateFTPScripts
'ShellWait appears to need a batch file, not a command line string
ShellWait LocalDirectory & "ptr99.bat", vbNormal
'Delete FTP script and batch file.
On Error Resume Next
    Kill LocalDirectory & "ptr99.dat"
    Kill LocalDirectory & "ptr99.bat"
    On Error GoTo 0
    
End Sub

Sub CreateFTPScripts()

    Dim fNum As Long
    'Dim sSITE As String
    'sSITE = FTPServerIP 'pickup the module variable
    
    '======= Create the script for FTP to use ======
    fNum = FreeFile()
    Open LocalDirectory & "ptr99.dat" For Output As fNum
    Print #fNum, "open " & FTPServerIP
    Print #fNum, "user " & FTPUsername & " " & FTPPassword
    Print #fNum, "cd " & FTPDirectory
    Print #fNum, "lcd " & LocalDirectory 'NB: This must be in correct case. FTP is case-sensitive even where Windoze isn't
    Print #fNum, "asc"
    Print #fNum, "Get ptr99 " & LocalDirectory & "ptr99.txt"
    Print #fNum, "quit"
    Close #fNum
    
    '======= Create a batch file to call with the shell command =======
    Open LocalDirectory & "ptr99.bat" For Output As fNum
    Print #fNum, Left(LocalDirectory, 2) 'was "P:". This is a chdrive command?
    Print #fNum, "ftp -n -s:ptr99.dat"
    Close #fNum
   
End Sub

Open in new window



'=======================================================================
'modShellWait
'This is used to ensure that code execution is paused
'until completion of the ftp script that retrieves the dummy printer
'output from the unix boxes.
'=======================================================================

'***************** Code Start ******************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code Courtesy of
'Terry Kreft
Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&

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

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
    hHandle As Long, ByVal dwMilliseconds As Long) As Long
    
Private 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
    
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
    hObject As Long) As Long
    
Public Sub ShellWait(Pathname As String, Optional WindowStyle As Long)
    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)
End Sub
'***************** Code End ****************

Open in new window

0
 
LVL 26

Assisted Solution

by:Nick67
Nick67 earned 250 total points
Comment Utility
Anyone have either an explanation or BETTER yet, and easier way to do this??

I adapted the code for use in my environment and it worked like a hot-damn -- but there's nothing to rename the files in the code. But

Dim myShell As Shell32.Shell
Dim localFolder As Shell32.Folder ' folder on PC
Dim ftpFolder As Shell32.Folder 'Ftp location

Set myShell = New Shell
Set localFolder = myShell.NameSpace("C:\juricta\OLCC") 'this is the destination folder
Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor/")
'Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor/") 'username
'Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor/") 'password
'Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor/") 'site  
'Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor/") 'subfolder
 
localFolder.CopyHere ftpFolder.Items.Item("Test3.txt")
'localFolder.CopyHere ftpFolder.Items.Item("Test3.txt") 'copy to the destination
'localFolder.CopyHere ftpFolder.Items.Item("Test3.txt") 'from the target
'localFolder.CopyHere ftpFolder.Items.Item("Test3.txt") 'just this item out of everything there.

Now -- if the site is up and exists, and the destination folder exists, this code should add C:\juricta\OLCC\Test3.txt
Adapted for my environment, it worked -- but it certainly has no error checking in it.
And the files are presently 0 bytes
My ftp host responds to PING so I check to see that it is up:

If Ping("10.0.1.10") = False Then
    MsgBox "The recorder is off, and the files cannot be refreshed"
    Exit Sub
End If


Your code works -- but it is downloading a 0 bytes file.
I am looking into that

Option Compare Database
Option Explicit

Private Sub Command0_Click()
'CODE for download
' Shell variant
' Requires reference to Microsoft Shell Controls and Automation
If Ping("www.randdcomputers.com") = False Then
    MsgBox "The site is down"
    Exit Sub
End If

Dim myShell As Shell32.Shell
Dim localFolder As Shell32.Folder ' folder on PC
Dim ftpFolder As Shell32.Folder

Set myShell = New Shell
Set localFolder = myShell.NameSpace("C:\tempPDF\one")
Set ftpFolder = myShell.NameSpace("ftp://juricta:Dltbgyd!982@www.randdcomputers.com/Liquor")
localFolder.CopyHere ftpFolder.Items.Item("Test3.txt")
Set ftpFolder = Nothing
Set localFolder = Nothing
Set myShell = Nothing
End Sub

Public Function Ping(strHost)
    Dim oPing, oRetStatus, bReturn
    Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address='" & strHost & "'")
 
    For Each oRetStatus In oPing
        If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
            bReturn = False
 
            ' WScript.Echo "Status code is " & oRetStatus.StatusCode
        Else
            bReturn = True
 
            ' Wscript.Echo "Bytes = " & vbTab & oRetStatus.BufferSize
            ' Wscript.Echo "Time (ms) = " & vbTab & oRetStatus.ResponseTime
            ' Wscript.Echo "TTL (s) = " & vbTab & oRetStatus.ResponseTimeToLive
        End If
        Set oRetStatus = Nothing
    Next
    Set oPing = Nothing
 
    Ping = bReturn
End Function

Open in new window

0
 
LVL 26

Expert Comment

by:Nick67
Comment Utility
I am unable to discover why it works, but then only brings down a 0 bytes file
I use 3 text files
1. ftpStart.bat
For you it would be

c:
cd \
cd c:\juricta\OLCC
ftp.exe -i -v -n -s:c:\juricta\OLCC\ftpcommands.txt
done.vbs


2. ftpcommands.txt as it is referenced there
for you it would be
Open ftp:\\www.randdcomputers.com
User juricta Dltbgyd!982
cd Liquor
mget Test3.txt
 


done.vbs as referenced in 1.
msgbox "Done!"

Sorry!  Your code looks good and works -- but not to pull down an actual file, and I can't find out why.
0
 

Author Closing Comment

by:juricta
Comment Utility
Both answers came back-to-back on initial reply.  SInce SimonAdept was 1st I would like to give him 350 of the 500 points.  Nick67's worked too so I would like to give him 150 points because the two came in so close together.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now