Using FTP in VBA (1 Viewer)

ajetrumpet

Banned
Local time
Today, 11:16
Joined
Jun 22, 2007
Messages
5,640
i recently had the need to find this code, for a reason i never thought i would use it for, so i'm posting it here. it uses VBA to PUT (FTP) a file to a server...
Code:
function FtpSend()
Dim vPath As String
Dim vFile As String
Dim vFTPServ As String
Dim fNum As Long

vPath = "PATH OF WHERE TO STORE THE DOS COMMANDS IN A .TXT FILE" (for example: "[COLOR="Red"]c:[/COLOR]")
vFile = "FULL PATH OF FILE TO SEND"
vFTPServ = "www.MYDOMAIN.com" 'your server

'Mounting file command for ftp.exe
fNum = FreeFile()
Open vPath & "\FtpComm.txt" For Output As #fNum
Print #1, "USER UsernameHere" 'use this if a UN is required
Print #1, "PasswordHere" 'use this if a PASS is required
Print #1, "put " & vFile ' upload local filename to server file
Print #1, "close" ' close connection
Print #1, "quit" ' Quit ftp program
Close

Shell "ftp -n -i -g -s:" & vPath & "\FtpComm.txt " & vFTPServ, vbNormalNoFocus

End function
here is an example i gave to someone who didn't know how to operate DOS, and needed to get files to me from a remote location...
Code:
function FtpSend()
Dim vPath As String
Dim vFile As String
Dim vFTPServ As String
Dim fNum As Long

vPath = "c:"
vFile = "c:\'documents and settings'\%username%\desktop" & _
          inputbox("Give the file name to upload from your desktop...")
vFTPServ = "www.MYDOMAIN.com" 'your server

'Mounting file command for ftp.exe
fNum = FreeFile()
Open vPath & "\FtpComm.txt" For Output As #fNum
Print #1, "USER UsernameHere"
Print #1, "PasswordHere"
Print #1, "put " & vFile ' upload local filename to server file
Print #1, "close" ' close connection
Print #1, "quit" ' Quit ftp program
Close

Shell "ftp -n -i -g -s:" & vPath & "\FtpComm.txt " & vFTPServ, vbNormalNoFocus

End function

<EDIT>

MY NEEDS FOR THIS THING now have expanded beyond my wildest expectations, but because the people I work for are not interested in buying the "GoToMyPC" thing, I guess we do this instead, through Access no less! Wow...talk about using programs for what they were NOT intended for. :rolleyes: At any rate, here is something that will give the user a chance to select as many folders as they want to upload to a server root directory. As the upload takes place and you see the DOS window on screen doing it's magic, there is a box that pops up on top of that even that says something "Wait until it's done, then press OK". (it wont work this way for others, because my popup for is customize with plenty of code. but in general, here's the IDEA:
PHP:
Option Compare Database

Function FTPtransfer()

Dim varitem As Variant
Dim vPath As String
Dim vFile As String
Dim vFTPServ As String
Dim fNum As Long

vPath = "C:"
vFTPServ = "www.mydomain.com"
jumpdone = False

fNum = FreeFile()

Open vPath & "\FtpComm.txt" For Output As #fNum
Print #1, "USER MYUSERNAMEHERE" ' your login
Print #1, "PASSWORDHERE" ' your password
Print #1, "echo Press any key to pick your files to be transferred to the server"
Print #1, pause

With Application.FileDialog(msoFileDialogFilePicker)

         With .Filters
           .Clear
           .Add "All Files", "*.*"
         End With

             .AllowMultiSelect = True
             .InitialFileName = "c:\"
             .InitialView = msoFileDialogViewDetails

                    If .Show Then

                      For Each varitem In .SelectedItems
                        If InStr(CStr(varitem), ".") > 0 Then
                            vFile = """" & varitem & """"
                            Print #1, "put " & vFile
                        End If
                      Next varitem

                    End If
                    
End With


Print #1, "close" ' close connection
Print #1, "quit" ' Quit ftp program
Close

Shell "ftp -n -i -g -s:" & vPath & "\FtpComm.txt " & vFTPServ, vbNormalNoFocus

DoCmd.OpenForm "msgboxOK"
Forms!msgboxOK!Message1.Caption = CStr(varitem) & _
                            " is uploading...  Press OK when it has finished"
Forms!msgboxOK!Message1.Visible = True
   While jumpdone = False
        DoEvents
   Wend


End Function
ANOTHER EXAMPLE

Here's a substitute for buying an FTP program that I wrote for , to upload, download and delete files from there personal directories on the server. Below is the upload code and download code I used. Quite simple really...(uses DOS FTP):
PHP:
Function UploadServerFiles()

DoCmd.Close acForm, "MsgBoxSelect"

Dim varitem As Variant
Dim vPath As String
Dim vFile As String
Dim vFTPServ As String
Dim fNum As Long

Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("Uploads", dbOpenDynaset)

vPath = "C:"
vFTPServ = "www.mydomain.com"
jumpdone = False

fNum = FreeFile()

Open vPath & "\FtpComm.txt" For Output As #fNum
Print #1, "USER myUserName" ' your login
Print #1, "MyPassword" ' your password
Print #1, "cd MyPersonalServerDirectory" 'DAD'S DIRECTORY

With Application.FileDialog(msoFileDialogFilePicker)

         With .Filters
           .Clear
           .Add "All Files", "*.*"
         End With

             .AllowMultiSelect = True
             .InitialFileName = "c:\"
             .InitialView = msoFileDialogViewDetails

                    If .Show Then

                      For Each varitem In .SelectedItems
                      
                        If InStr(CStr(varitem), ".") > 0 Then
                            vFile = """" & varitem & """"
                            Print #1, "put " & vFile
                                rs.AddNew
                                    rs!TransferPerson = application.currentuser
                                    rs!fileuploaded = varitem
                                    rs!UploadDate = Date
                                rs.Update
                        End If
                      Next varitem

                    End If

If .SelectedItems.Count > 0 Then
   Cancelled = False
End If

End With

Print #1, "close" ' close connection
Print #1, "quit" ' Quit ftp program
Close

If Cancelled = False Then

Shell "ftp -n -i -g -s:" & vPath & "\FtpComm.txt " & vFTPServ, vbNormalFocus

                            jumpdone = False
                            DoCmd.OpenForm "msgboxOK"
                            Forms!MsgBoxOK!Message1.Visible = True
                                While jumpdone = False
                                    DoEvents
                                Wend

DoCmd.OpenTable "Uploads", acViewNormal, acReadOnly
DoCmd.Maximize

                            jumpdone = False
                            DoCmd.OpenForm "msgboxOK"
                            Forms!MsgBoxOK!mESSAGE2.Visible = True
                                While jumpdone = False
                                    DoEvents
                                Wend

DoCmd.Close acTable, "Uploads"
End If

Cancelled = True
rs.Close
Set rs = Nothing

DoCmd.OpenForm "MsgBoxSelect"

End Function
PHP:
Function DownloadServerFiles()

Dim DownloadLoc As String

If DCount("fileuploaded", "uploads") < 1 Then
   MsgBox "You have no files on the server", vbCritical
      Exit Function
End If

DoCmd.Close acForm, "MsgBoxSelect"
DoCmd.SetWarnings False

Dim varitem As Variant
Dim vPath As String
Dim vFile As String
Dim vFTPServ As String
Dim fNum As Long

DoCmd.OpenQuery "Get", acViewNormal, acEdit

                            jumpdone = False
                            DoCmd.OpenForm "msgboxOK"
                            Forms!MsgBoxOK!Message5.Visible = True
                                While jumpdone = False
                                    DoEvents
                                Wend

DoCmd.Close acQuery, "Get", acSaveYes

If DCount("fileuploaded", "uploads", "[get] = -1") < 1 Then
   MsgBox "No files were Selected...", vbExclamation
   DoCmd.OpenForm "MsgBoxSelect"
      Exit Function
End If

MsgBox "Select your download location..."
With Application.FileDialog(msoFileDialogFolderPicker)

             .AllowMultiSelect = False
             .InitialFileName = "c:\"
             .InitialView = msoFileDialogViewDetails

                    If .Show Then
                      For Each varitem In .SelectedItems
                         DownloadLoc = CStr(varitem) & "(forward slash) here"
                      Next varitem
                    End If

End With
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("Get", dbOpenDynaset)

rs.MoveLast
rs.MoveFirst

vPath = "C:"
vFTPServ = "www.mydomain.com"

fNum = FreeFile()

Open vPath & "\FtpComm.txt" For Output As #fNum
Print #1, "USER UserName" ' your login
Print #1, "Password" ' your password
Print #1, "cd MyPersonalDirectory"

While Not rs.EOF
   If rs!Get = -1 Then
      vFile = Right(rs!fileuploaded, (Len(rs!fileuploaded) - 
               InStrRev(rs!fileuploaded, "\")))
         Print #1, "get " & """" & vFile & """" & " " & DownloadLoc & vFile
   End If
         rs.MoveNext
Wend

Print #1, "close" ' close connection
Print #1, "quit" ' Quit ftp program
Close
                            
rs.Close
Set rs = Nothing
                            
                            jumpdone = False
                            DoCmd.OpenForm "msgboxOK"
                            Forms!MsgBoxOK!Message6.Visible = True
                                While jumpdone = False
                                    DoEvents
                                Wend
                                
Shell "ftp -n -i -g -s:" & vPath & "\FtpComm.txt " & vFTPServ, vbNormalFocus

DoCmd.RunSQL "UPDATE Uploads SET Uploads.Get = 0"
DoCmd.SetWarnings True
DoCmd.OpenForm "MsgBoxSelect"

End Function
I have attached an FTP application that can be used on any local machine. It connect to remote servers if you put the right data into it! I suppose this is a bit too much to post on here, but it is actually a pretty good program I wrote. Whoever uses it, Enjoy!
 

Attachments

  • FTP.zip
    60.9 KB · Views: 4,311
Last edited:

DCrake

Remembered
Local time
Today, 17:16
Joined
Jun 8, 2005
Messages
8,634
Hi AJ,
Actually using VB to for my FTP applet. here is the code so far.


Code:
   'Variables
    sServer = txtServer.Text
    sUser = txtUser.Text
    sPassword = txtPassword.Text
    sDir = txtDir.Text
    sLocal = App.Path & "\Database\" & TxtFile.Text
    sRemote = "\docs\stuff\" & TxtFile.Text
    
    'Save values to remember
    SaveSetting "PutGet FTP", "Values", "Server", txtServer.Text
    SaveSetting "PutGet FTP", "Values", "User", txtUser.Text
    SaveSetting "PutGet FTP", "Values", "Password", txtPassword.Text
    SaveSetting "PutGet FTP", "Values", "Directory", txtDir.Text
    
'Open INTERNET
    hOpen = InternetOpen("PutGet FTP", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    If hOpen = 0 Then 'ZERO means Internet Coudn't Open
        MsgBox "Error: " & Err.LastDllError, 32, "Internet Conection Error"
        Status.Caption = "Disconnected..."
        Exit Sub
    End If
    Status.Caption = "Internet Open..."
    
    dwType = FTP_TRANSFER_TYPE_BINARY 'SET TO BINARY
    dwSeman = 0 'Set Conection Active
    hConnection = 0 'Reset Conection
    
'Connect to server
    hConnection = InternetConnect(hOpen, sServer, INTERNET_INVALID_PORT_NUMBER, sUser, sPassword, INTERNET_SERVICE_FTP, dwSeman, 0)
    If hConnection = 0 Then 'ZERO means can't connect to Server
        MsgBox "Error: " & Err.LastDllError, 32, "Server Conection Error"
        Status.Caption = "Disconnected..."
        Exit Sub
    End If
    Status.Caption = "Connected to Server..."

'Specify Initial Directory
    OpenDir = FtpSetCurrentDirectory(hConnection, sDir)
    If OpenDir = False Then 'False means specified directory is wrong
        MsgBox "Error: " & Err.LastDllError, 32, "Initial Directory Error"
        Status.Caption = "Disconnected..."
        If hConnection <> 0 Then 'Disconnect if is still conected
            Cerrar = InternetCloseHandle(hConnection)
        End If
        Exit Sub
    End If
    Status.Caption = "Directory Ready..."

Everything woks up to this point

The put file below fails as Subir = False

Code:
'Put File
    Subir = FTPPutFile(hConnection, sLocal, sRemote, dwType, 0)
    If Subir = False Then 'False means couldn't send the file
        MsgBox "Error: " & Err.LastDllError, 32, "File Transfer Error"
        Status.Caption = "Disconnected..."
        If hConnection <> 0 Then 'Disconnect if is still conected
            Cerrar = InternetCloseHandle(hConnection)
        End If
        Exit Sub
    End If
    Status.Caption = "Sending File..."

Having read what's there I'm wondering if Subir should infact be SubDir
Going to test it.
Code:
'Close conection
    If hConnection <> 0 Then
        Cerrar = InternetCloseHandle(hConnection)
        Status.Caption = "Disconnected..."
    End If

Tried it, still have problems! Any idea what could be preventing the file transfer bit.

David
 
Last edited:

KirkComer

Registered User.
Local time
Today, 12:16
Joined
Oct 21, 2005
Messages
50
ajetrumpet,

I know this is a old post but thank you so much for posting this ftp to network database! I do have one question about it. For example if I wanted to save a ftp file to a folder in my C drive what is the proper way to type this?

Example 1 (this works)
Me.Text26 = "C:\"
Call FillList("C:\")

Example 2 (this doesn't)
Me.Text26 = "C:\Test Folder"
Call FillList("C:\Test Folder")

It seems like it should work. I highlight the file and click "Download File". No error message appear but the file does not tranfer to the folder. Probably just something small but my simple brain can not figure it out. lol
 

boblarson

Smeghead
Local time
Today, 09:16
Joined
Jan 12, 2001
Messages
32,068
ajetrumpet,

I know this is a old post but thank you so much for posting this ftp to network database! I do have one question about it. For example if I wanted to save a ftp file to a folder in my C drive what is the proper way to type this?

Example 1 (this works)
Me.Text26 = "C:\"
Call FillList("C:\")

Example 2 (this doesn't)
Me.Text26 = "C:\Test Folder"
Call FillList("C:\Test Folder")

It seems like it should work. I highlight the file and click "Download File". No error message appear but the file does not tranfer to the folder. Probably just something small but my simple brain can not figure it out. lol

What if you put the slash like the first example has:

Me.Text26 = "C:\Test Folder\"
Call FillList("C:\Test Folder\")
 

KirkComer

Registered User.
Local time
Today, 12:16
Joined
Oct 21, 2005
Messages
50
Yes. I also tried (I'm guessing you didn't want me to use the *):

Example 3
Me.Text26 = "C:\Test Folder\"
Call FillList("C:\Test Folder\")

I can make do with just putting it on my C:\ drive for now but if anyone comes up with a solution please let me know. :)
 

boblarson

Smeghead
Local time
Today, 09:16
Joined
Jan 12, 2001
Messages
32,068
Yes. I also tried (I'm guessing you didn't want me to use the *):

Example 3
Me.Text26 = "C:\Test Folder\"
Call FillList("C:\Test Folder\")

I can make do with just putting it on my C:\ drive for now but if anyone comes up with a solution please let me know. :)

I'm guessing that the code doesn't like the spaces in the folders and is using the older 8.3 file naming structure. See what happens if you have a test folder named:

C:\testFold\

and see if it works then.
 

KirkComer

Registered User.
Local time
Today, 12:16
Joined
Oct 21, 2005
Messages
50
Yep. I tried. Still no luck. Thanks for the suggestions.

Example 4
Me.Text26 = "C:\TestFolder\"
Call FillList("C:\TestFolder\")

Example 5
Me.Text26 = "C:\TestFolder"
Call FillList("C:\TestFolder")
 

boblarson

Smeghead
Local time
Today, 09:16
Joined
Jan 12, 2001
Messages
32,068
Yep. I tried. Still no luck. Thanks for the suggestions.

Example 4
Me.Text26 = "C:\TestFolder\"
Call FillList("C:\TestFolder\")

Example 5
Me.Text26 = "C:\TestFolder"
Call FillList("C:\TestFolder")
Apparently you didn't pay attention. I said

C:\TestFold\

Not
C:\TestFolder

TestFold is 8 characters long, which is what 8.3 uses. Remember back when you could not use file or folder names longer than 8 characters? Well, I think this is what is happening. Try using

C:\TestFold\

(8 characters)

and only 8 characters for the file name as well.

See what happens.
 

KirkComer

Registered User.
Local time
Today, 12:16
Joined
Oct 21, 2005
Messages
50
Cha-Ching! This worked!!

Example 6
Me.Text26 = "C:\Test\"
Call FillList("C:\Test\")

Thank you soooooo muuccchhhh!
 

Users who are viewing this thread

Top Bottom