FTP to specified folder

[D Willett]

I can upload files to a web server but only to the root of my account. Follows is 3 versions of code I have tried to put the files into the folder 200648, all files will upload but always to the root ??

'frmFtpAll.FTPFile "myFTPsite", "PUT", "User", "Password", FTPSource, FTPFile
'frmFtpAll.FTPFile "myFTPsite/public_html/Image_Client/200648", "PUT", "User", "Password", FTPSource, FTPFile
frmFtpAll.FTPFile "myFTPsite/Image_Client/200648", "PUT", "User", "Password", FTPSource, FTPFile

Does anyone with FTP experience know how to remedy this?
Can I also create a folder so I can replace 200648 with a folder I create??

Cheers

[Leif]

From my very limited experience, I think you need to change folder before uploading.

Basic FTP Commands may help - it gives the commands for making and removing folders.

[D Willett]

Thanks Leif.
So it seems I have to create the directory "MKDIR" and then Change to that directory "CD". My code successfully creates ( in this case ) "20055" changes to that directory, uploads one image and then doesn't upload further images?
If I rem out the two lines:

Code: Select all

Inet1.Execute , "MKDIR " & 20055
Inet1.Execute , "CD " & 20055

All files upload to the root. So this tells me the MKDIR and CD do not loop?
I'm a bit stumped here now

Code: Select all

Option Explicit

Private msCurrentFile As String

Friend Sub FTPFile(ByVal sFTPServer As String, _
                               ByVal sFTPCommand As String, _
                               ByVal sFTPUser As String, _
                               ByVal sFTPPwd As String, _
                               ByVal sFTPSrcFileName As String, _
                               ByVal sFTPTgtFileName As String)
                               
  'Dim strrefFTP As String
  'strrefFTP = InputBox("Please Enter A Number to Create A Folder ", "")

   Dim oFS As Scripting.FileSystemObject
   Dim sURL As String

   On Error GoTo FTPFileExit

   Me.HRG True
   msCurrentFile = ""

   Set oFS = New Scripting.FileSystemObject

   sURL = "ftp://" & sFTPUser & ":" & sFTPPwd & "@" & sFTPServer

   Inet1.Protocol = icFTP
   Inet1.RequestTimeout = 60
   Inet1.RemotePort = 21
   Inet1.AccessType = icDirect
   Inet1.URL = sURL

   Select Case sFTPCommand

   Case "PUT"
   
      msCurrentFile = sFTPSrcFileName
      If oFS.FileExists(sFTPSrcFileName) = False Then GoTo FTPFileExit
      'Inet1.Execute , "MKDIR " & strrefFTP
      'Inet1.Execute , "CD " & strrefFTP
      Inet1.Execute , "MKDIR " & 20055
      Inet1.Execute , "CD " & 20055
      
      Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName
    
   Case "GET"

      msCurrentFile = sFTPTgtFileName
      If oFS.FileExists(sFTPTgtFileName) = True Then oFS.DeleteFile sFTPTgtFileName, True
      Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName

   End Select

   Me.WaitForResponse
   Inet1.Execute sURL, "quit"
   Me.WaitForResponse

FTPFileExit:
   Set oFS = Nothing
   HRG False
End Sub


Friend Sub WaitForResponse()

   Dim fWait As Boolean

   On Error GoTo ErrHandler

   fWait = True
   Do Until fWait = False
      DoEvents
      fWait = Inet1.StillExecuting
   Loop

ErrHandler:
   Err.Clear
End Sub

Private Sub Command1_Click()
   
   If Me.List1.SelCount = 0 Then
      MsgBox "You Must Select Who To Send The Files To", vbInformation, "FTP Selection"
      Exit Sub
   End If


   Dim N As Integer
   Dim FTPPath As String
   Dim FTPSource As String
   Dim strref As String
   Dim FF As String         'Final FileName
   Dim SF As String
   Dim DF As String
   Dim AF As String         'Archive folder
   Dim intMax As Integer
   Dim intPos As Integer
   Dim intPos2 As Integer
   Dim intSeq As Integer
   Dim fName As String
   Dim Ext As String
   Dim pos1 As Integer, pos2 As Integer
   Dim pos1str As String, pos2str As String
   Dim FTPFile As String
   
  pos1 = InStrRev(List2.List(N), "-") '6
  pos2 = InStrRev(List2.List(N), "\", pos1 - 1) '0
  pos1str = Mid(List2.List(N), pos2 + 1, pos1 - 1) 
            

   Select Case List1
   
   Case "M&M Leek"

      strref = InputBox("Please Enter A Job Number To Rename The Sent Files", "")
      
      If strref = "" Then
         MsgBox "You Must Enter A Job Number Before Proceeding", vbInformation, "Reference Error"
         Exit Sub
      End If
      
            For N = 0 To List2.ListCount - 1

            If Right(List2.List(N), 3) = "jpg" Then
            
                pos2str = Mid(List2.List(N), pos1)
                FTPSource = "L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(N)
                FTPFile = strref & pos2str
                
            End If
            
              
            If Right(List2.List(N), 3) = "pdf" Then
                pos2str = Mid(List2.List(N), pos1)
                FTPSource = "L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(N)
                FTPFile = strref & pos2str
                
            End If
                  
            frmFtpAll.FTPFile "ServerLeek", "PUT", "mm", "mm999", FTPSource, FTPFile

     
            Next N


   Case "M&M Longton"

      strref = InputBox("Please Enter A Job Number To Rename The Sent Files", "")
      
      If strref = "" Then
         MsgBox "You Must Enter A Job Number Before Proceeding", vbInformation, "Reference Error"
         Exit Sub
      End If
      
            For N = 0 To List2.ListCount - 1

            If Right(List2.List(N), 3) = "jpg" Then
            
                pos2str = Mid(List2.List(N), pos1)
                FTPSource = "L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(N)
                FTPFile = strref & pos2str
                
            End If
            
              
            If Right(List2.List(N), 3) = "pdf" Then
                pos2str = Mid(List2.List(N), pos1)
                FTPSource = "L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(N)
                FTPFile = strref & pos2str
                
            End If
                  
            frmFtpAll.FTPFile "ServerLongton", "PUT", "mm", "mm999", FTPSource, FTPFile

     
            Next N
            
  Case "Web Server"

      strref = InputBox("Please Enter A Job Number To Rename The Sent Files", "")
      
      If strref = "" Then
         MsgBox "You Must Enter A Job Number Before Proceeding", vbInformation, "Reference Error"
         Exit Sub
      End If
      
            For N = 0 To List2.ListCount - 1

            If Right(List2.List(N), 3) = "jpg" Then
            
                pos2str = Mid(List2.List(N), pos1)
                FTPSource = "L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(N)
                FTPFile = strref & pos2str
                
            End If
            
              
            If Right(List2.List(N), 3) = "pdf" Then
                pos2str = Mid(List2.List(N), pos1)
                FTPSource = "L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(N)
                FTPFile = strref & pos2str
                
            End If

            frmFtpAll.FTPFile "myFTPsite", "PUT", "User", "Password", FTPSource, FTPFile

     
            Next N


      End Select

        MAPISession1.SignOn
        With MAPIMessages1
            .SessionID = MAPISession1.SessionID
            .Compose
            .MsgSubject = "Files Transferred For Your Reference Number : " & strref
            .MsgNoteText = Space(List2.ListCount) & vbCrLf & "Transferred From " & CompName & vbCrLf & _
               "Please View From The Estimator Console"
            .Send True
            

      End With
      On Error Resume Next
exitHandler:
      MAPISession1.SignOff

errorHandler:
      If Err <> 0 Then
         MsgBox Err.Description & " " & Err.Number & " Contact M&M Technologies 01782 8" & vbCrLf & _
               " Quoting This Error Message", vbCritical, "Error"
         Resume exitHandler
      End If
   Unload Me
End Sub

Private Sub Form_Load()
   Dim N As Integer

   With List1

      .AddItem "M&M Leek"
      .AddItem "M&M Longton"
      .AddItem "Web Server"
   End With

   With List2
      For N = 0 To Form1024Image.lstArch.ListCount - 1
         .AddItem Form1024Image.lstArch.List(N)
      Next N

   End With
   selImages True

End Sub

Private Sub Inet1_StateChanged(ByVal State As Integer)

   On Error Resume Next

   Select Case State
   Case icNone
   Case icResolvingHost: Me.lblResponse.Caption = "Resolving Host"
   Case icHostResolved: Me.lblResponse.Caption = "Host Resolved"
   Case icConnecting: Me.lblResponse.Caption = "Connecting..."
   Case icConnected: Me.lblResponse.Caption = "Connected"
   Case icResponseReceived: Me.lblResponse.Caption = "Transferring File:" & Space(5) & msCurrentFile
   Case icDisconnecting: Me.lblResponse.Caption = "Disconnecting..."
   Case icDisconnected: Me.lblResponse.Caption = "Disconnected"
   Case icError: MsgBox "FTP Error: " & Inet1.ResponseCode & " " & Inet1.ResponseInfo
   Case icResponseCompleted: Me.lblResponse.Caption = "Process Complete."
   End Select

   Me.lblResponse.Refresh

   Err.Clear

End Sub

Friend Sub HRG(fShowHourGlass As Boolean)

   If fShowHourGlass = True Then
      Screen.MousePointer = 11
   Else
      Screen.MousePointer = 0
   End If

End Sub

[Leif]

Now you're well beyond where I'm much use I think!

If I'm understanding correctly, could it be that once you have created the folder, there is an objection to it being remade, and that all you need to do each time is change folder?
Can you check for the existence of the folder, then change folder if it's there, else create the (new) folder and change folder?

[D Willett]

I never saw it that way, but yes once the folder is made ( I've checked, it is made ) it doesn't like to be remade again.
One file is uploaded then the other files are skipped over so I think too its the directory change its not liking.

If I rem out the upload line:
Inet1.Execute sURL, sFTPCommand & Space(1) & sFTPSrcFileName & " " & sFTPTgtFileName
I get error 12003 550, Can't create directory:file exists

Cheers

[D Willett]

This is where I got, I had to change the forms code and create a function which can be found here for future members projects:
Just having a problem updating lblResponse, it doesn't show what files are being uploaded.
Any improvements with this would be appreciated ( but it works as it is )

Regards

http://www.mcmillan.org.nz/Programming/ ... Class.aspx" onclick="window.open(this.href);return false;

Code: Select all

Private Sub WebServer()

    Dim ftp    As FTPClass
    Dim f      As FTPFileClass
    Dim TestFolder As String
    Dim WorkingJobNo As String
    Dim n      As Integer
    Dim pos1 As Integer, pos2 As Integer
    Dim pos1str As String, pos2str As String
    Dim WorkingJobFolder As String
    Dim Temp   As String

    Set ftp = New FTPClass

    pos1 = InStrRev(List2.List(n), "-")    '6
    pos2 = InStrRev(List2.List(n), "\", pos1 - 1)    '0
    pos1str = Mid(List2.List(n), pos2 + 1, pos1 - 1)    '98754

    'Connect to Server... Server, User, Password
    If ftp.OpenFTP("ftpSite", "User", "PW") Then
        HRG True
        '   frmWait.Show

        'Change to main folder
        ftp.SetCurrentFolder ("/public_html/Image_Client")

        'Get User Input for job number
        WorkingJobNo = InputBox("Please Enter A Job Number To Rename The Sent Files", "")

        'If job folder does not exist, create folder
        If (ftp.FolderExists(WorkingJobNo) = False) Then
            ftp.CreatFolder (WorkingJobNo)
        End If

        'Change working folder to job folder
        ftp.SetCurrentFolder (ftp.CurrentFolder + "/" + WorkingJobNo)
        'Now to be used as a bookmark for returning
        WorkingJobFolder = ftp.CurrentFolder

        'Loop through List
        For n = 0 To List2.ListCount - 1
            'Filter only jpg
            If Right(List2.List(n), 3) = "jpg" Then

                'Return working folder to root of job
                ftp.SetCurrentFolder (WorkingJobFolder)

                'Delete file from FTP server if already exists
                ftp.DeleteFile (List2.List(n))

                'Get new name for file

                Temp = Replace(List2.List(n), pos1str, WorkingJobNo)

                'Upload to FTP serverwith fail message
                If (ftp.PutFile("L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(n), Temp, True) = False) Then
                    MsgBox "failed"

                Else

                End If

            End If

            If Right(List2.List(n), 3) = "pdf" Then

                'Return working folder to root of job
                ftp.SetCurrentFolder (WorkingJobFolder)

                'Delete file from FTP server if already exists
                ftp.DeleteFile (List2.List(n))

                'Get new name for file

                Temp = Replace(List2.List(n), pos1str, WorkingJobNo)

                'Upload to FTP serverwith fail message
                If (ftp.PutFile("L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & List2.List(n), Temp, True) = False) Then
                    MsgBox "failed"

                Else

                End If

            End If

        Next n
        Me.lblResponse.Caption = "Transferring File:" & Space(5) & List2.List(n) & Temp

    End If

    If (ftp.PutFile("L:\Mmpdf\ConsoleFiles\" & pos1str & "\" & pos1str & ".csv", WorkingJobNo & ".csv", True) = False) Then
        MsgBox "failed"
    End If

    'Close FTP Connection
    HRG False
    'frmWait.Hide

    MsgBox "all done"
    ftp.CloseFTP
End Sub