Can't connect to FTP site from Microsoft Access

Could you post your Operating System and the version of Access you are currently using?

here is the code, minus the passwords

Option Compare Database
Option Explicit

Private Sub cboLocation_AfterUpdate()
Me.Requery
End Sub

Private Sub cmdFTP_Click()

Dim strAccount As String
Dim strPassword As String
Dim strDest As String

Const conRover = "ftp://ftp.storagemadeeasy.com"
Const conActiv4Pets = "spcala@activ4pets.com"
On Error GoTo Proc_Error

' initialize paths for different locations

Select Case Me.cboLocation
    Case "Long Beach"
        strAccount = "CA366"
        strPassword = "54"
        SPCALAExport strAccount, strPassword
        Exit Sub
       
    Case "South Bay"
        strAccount = "CA1612"
        strPassword = "50z"
        SPCALAExport strAccount, strPassword
        Exit Sub
       
    Case "Pico Rivera"  ' Pico credentials.  Note that if the account is  Ca2356, the text file uploaded should be named Ca2353.txt (it should match the account) **********
        strAccount = "CA2356"
        strPassword = "222222"
        SPCALAExport strAccount, strPassword
        Exit Sub

       
    Case "SPCALA Webpage"
        strAccount = "@spcala.com"
        strPassword = ""
        SPCALAExport strAccount, strPassword
        Exit Sub

       
    Case "Finding Rover"
        strAccount = "laspca@findingrover"
        strPassword = "laspcafindingR0ver"
        FindingRoverExport conRover, strAccount, strPassword
        Exit Sub
       
    Case "activ4pets"
        strDest = conActiv4Pets
        Activ4PetsExport (strDest)
        Exit Sub
   
    Case Else
        MsgBox "Please select Long Beach or South Bay as location, or select SPCALA Webpage"
        Exit Sub
End Select

PROC_EXIT:
    On Error Resume Next
    Exit Sub
   
Proc_Error:
    MsgBox "Error " & Err.Number & " in cmdFTP_Click:" & vbCrLf & Err.Description

    Resume PROC_EXIT

End Sub


Sub InitFTPObject(objFTP As FTP, strPath As String, strPage As String, strDest As String, strAccount As String, strPassword As String)
        With objFTP
            .SourceFile = strPath
            .FtpURL = strPage
            .DestinationFile = strDest
            .AutoCreateRemoteDir = False
            .ConnectToFTPHost strAccount, strPassword
            .UploadFileToFTPServer
        End With
End Sub

Private Sub SPCALAExport(strAccount As String, strPassword As String)
Dim objFTP As FTP
Dim strPath As String
Dim imgPath As String
Dim ftpPath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFail As DAO.Recordset
Dim ErrCount As Integer


Const conTARGET = "ftp://members.petfinder.com"
Const conRover = "ftp://ftp.storagemadeeasy.com"
Const conWEBPAGE = "ftp://spcala.com"
Const PathName = "\\databases\access2015\Petfinder"
On Error GoTo Proc_Error

' initialize progress tracking textboxes

Me!txtAvailable = Me.RecordsetClone.RecordCount
If Me.cboLocation = "SPCALA Webpage" Then
    Me!txtAvailable = DCount("*", "qryWebpageExport")
End If
Me!txtSent = 0
Me!txtNoPic = 0
Me!txtTotal = 0
ErrCount = 0




' export the query
If Me.cboLocation = "SPCALA Webpage" Then
    strPath = PathName & "\adoptable.txt"
    'Application.ExportXML ObjectType:=acExportQuery, _
    'DataSource:="qryWebpageExport", _
    'datatarget:=strPath
    DoCmd.TransferText acExportDelim, "Webpage Export Specification", _
      "qryWebpageExport", strPath, True

    Set objFTP = New FTP
    With objFTP
        .SourceFile = strPath
        .FtpURL = conWEBPAGE
        .DestinationFile = "adoptable.txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With


Else
    strPath = PathName & "\" & strAccount & ".txt"
    DoCmd.TransferText acExportDelim, "Petfinder Export Specification", "qryPetfinderExport", strPath, True
    Set objFTP = New FTP
    With objFTP
        .SourceFile = strPath
        .FtpURL = conTARGET
        .DestinationFile = "/import/" & strAccount & ".txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With
End If

'export all pictures

imgPath = DLookup("DefaultImagePath", "tbl_ImageDefaultPath", "ImageType='SoftSlips'")

Set db = CurrentDb
Set rsFail = db.OpenRecordset("tblPetfinderFailures", dbOpenDynaset)

If Me.cboLocation = "SPCALA Webpage" Then
    Set rs = db.OpenRecordset("qryWebpageExport", dbOpenDynaset)
Else
    Set rs = Me.RecordsetClone
End If
rs.MoveFirst
With objFTP
    If Me.cboLocation = "SPCALA Webpage" Then
        .FtpURL = conWEBPAGE
    Else
        .FtpURL = conTARGET
    End If
    .ConnectToFTPHost strAccount, strPassword
End With

' set initial ftp
If Me.cboLocation = "SPCALA Webpage" Then
    ftpPath = ""
Else
    ftpPath = "/import/photos/"
End If
Do Until rs.EOF
TryAgain:
    If Len(rs!SoftSlipPicPathFile & "") <> 0 Then
        If Dir(rs!SoftSlipPicPathFile) <> "" Then
            If Me.cboLocation <> "SPCALA Webpage" Then
                Me.Bookmark = rs.Bookmark
            End If
            With objFTP
                '.SourceFile = imgPath & "\" & rs!SoftSlip & ".jpg"
                .SourceFile = rs!SoftSlipPicPathFile
                .DestinationFile = ftpPath & rs!SoftSlip & ".jpg"
                .UploadFileToFTPServer
            End With
            ' since the focus is now on the photos folder, we don't need the path any more
            'If Me.cboLocation <> "SPCALA Webpage" Then
                ftpPath = ""
            'End If
            Me!txtUploading = rs!SoftSlip
            Me!txtSent = Me!txtSent + 1
        Else
            Me!txtNoPic = Me!txtNoPic + 1
        End If
    Else
        Me!txtNoPic = Me!txtNoPic + 1
    End If
    Me!txtTotal = Me!txtTotal + 1
    Me.Repaint
    rs.MoveNext
Loop
PROC_EXIT:
    On Error Resume Next
    Set objFTP = Nothing
    Exit Sub
   
Proc_Error:
    Select Case Err.Number
        Case -2147219289 ' FTP switching to binary
            'MsgBox "FTP switching to binary, retrying " & rs!SoftSlip
            ErrCount = ErrCount + 1
            If ErrCount < 6 Then
                With objFTP
                    If Me.cboLocation = "SPCALA Webpage" Then
                        .FtpURL = conWEBPAGE
                    Else
                        .FtpURL = conTARGET
                    End If
                    .ConnectToFTPHost strAccount, strPassword
                End With
                Resume TryAgain
            Else
                ' msgbox commented out per JR's request
                'MsgBox "Too many FTP errors for " & rs!SoftSlip & ", skipping to next picture"
                rsFail.AddNew
                    rsFail!SoftSlip = rs!SoftSlip
                    rsFail!faildate = Now
                rsFail.Update
               
                ErrCount = 0
                rs.MoveNext
                If rs.EOF Then
                    Resume PROC_EXIT
                Else
                    Resume TryAgain
                End If
            End If
        Case Else
            MsgBox "Error " & Err.Number & " in cmdFTP_Click:" & vbCrLf & Err.Description
    End Select
    Resume PROC_EXIT
End Sub



Private Sub Form_Current()
' Update image for this animal
Dim strPath As String
Dim strFile As String
On Error Resume Next
strPath = DLookup("DefaultImagePath", "tbl_ImageDefaultPath", "ImageType='SoftSlips'")
'strFile = strPath & "\" & Me!SoftSlip & ".jpg"
strFile = Nz(Me!SoftSlipPicPathFile, strPath & "\NoPicture.jpg")
If Dir(strFile) <> "" Then
    Me.imgAnimalPicture.Picture = strFile
End If

End Sub
Private Sub cmdClose_Click()
On Error GoTo Err_cmdclose_Click


    DoCmd.close

Exit_cmdclose_Click:
    Exit Sub

Err_cmdclose_Click:
    MsgBox Err.Description
    Resume Exit_cmdclose_Click
   
End Sub

Sub FindingRoverExport(strTARGET As String, strAccount As String, strPassword As String)
    Dim strPath As String
    Dim strZip As String
    Dim strTxt As String
    Dim strTo As String
    Dim strTitle As String
    Dim strMsg As String
    Dim strSQL As String
    Dim rs As DAO.Recordset
    Dim rsHistory As DAO.Recordset
    Dim s As String
    Dim i As Integer
    Dim arrPic() As String
    Dim strRoverPicPath As String
    Dim strRoverPic As String
    Dim objFTP As FTP
   
    '*************  File paths **************************
    strRoverPicPath = "" & DLookup("Rover", "tblPaths")
    strPath = "C:\Paw Trax\FindingRoverFiles"
    strZip = "C:\Paw Trax\FindingRoverFiles\FindingRover.zip"
    strTxt = "C:\Paw Trax\FindingRoverFiles\FindingRover.txt"
    '******************************************************
   
    On Error Resume Next
    DoCmd.Hourglass True
    If Dir(strPath & "\") & "" = "" Then
        MkDir strPath
    Else
        Kill strZip
        Kill strTxt
       
    End If
    On Error GoTo PROC_ERR
   
    strSQL = "DELETE * FROM tblTEMPFindingRover"
    CurrentDb.Execute strSQL, dbFailOnError + dbSeeChanges
    Do Until DCount("*", "tblTEMPFindingRover") = 0
        DoEvents
    Loop
   
    If DCount("*", "qryFindingRoverUpdates") = 0 Then
        MsgBox "There are no new or updated records to send"
        GoTo PROC_EXIT
    End If
   
    'DoCmd.OpenReport "rptFindingRoverUpdates", acViewPreview
    '  Save report in PDF format, and open it for display
    DoCmd.OutputTo acOutputReport, "rptFindingRoverUpdates", acFormatPDF, strPath & "\" & Format(Now, "yyyymmddhhnnss") & "_FindingRover.pdf", True
    DoCmd.OpenQuery "qryupdFindingRoverExport"
    DoEvents
   
    strSQL = "SELECT SoftSlip, Pic, EncodedImage FROM tblTEMPFindingRover WHERE Pic & '' <> '' AND pic NOT LIKE '*NoImage*'"
    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
    Do Until rs.RecordCount = 0 Or rs.EOF
        'arrPic = Split(rs("Pic"), "\")
        arrPic = Split(rs("Pic"), "Pet-Ark\")
        strRoverPic = strRoverPicPath & arrPic(UBound(arrPic))
        s = Replace(Replace(ImageToBase64Encoded(strRoverPic), Chr(10), ""), Chr(13), "")
        If s <> "COULD NOT ENCODE SPECIFIED FILE" Then
            rs.Edit
            rs("EncodedImage") = s
            rs.Update
        End If
        rs.MoveNext
    Loop

   
   
    strPath = strPath & "\FindingRover"
   
    ' Export query to csv and put it in a zip file
    DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    Zip strZip, strTxt
   
    ' ftp text file to finding rover
    ' strPath = PathName & "\" & strAccount & ".txt"
    DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    Set objFTP = New FTP
    With objFTP
        .SourceFile = strTxt
        .FtpURL = strTARGET
        .DestinationFile = "/Shelters/LASPCAProd/" & Format(Now, "yyyymmddhhnnss") & "_FindingRover" & ".txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With
     
    MsgBox "Data sent to Finding Rover"
    ' Attach Zip file to email
    ' 2015-10-22 -- replaced the email code with the above FTP code.
    'strTo = ""
    'strTitle = "Finding Rover Files"
    'strMsg = "See attached."
    'SendEmail strTo, strMsg, strTitle, strZip
   
   
   
    ' Update/Add changed or new records to history table
    strSQL = "SELECT * FROM qryFindingRoverUpdates"
    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
    Do Until rs.RecordCount = 0 Or rs.EOF
        strSQL = "SELECT * FROM tblFindingRoverHistory WHERE SoftSlip = '" & rs("SoftSlip") & "'"
        Set rsHistory = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
        With rsHistory
            If .RecordCount = 0 Then .AddNew Else .Edit
            For i = 0 To (rs.Fields.Count - 1)
                .Fields(i) = rs.Fields(i)
            Next
            !DateSent = Now()
            .Update
        End With
        rsHistory.close
        Set rsHistory = Nothing
        rs.MoveNext
    Loop
   
   
PROC_EXIT:

    DoCmd.Hourglass False
   
   
    On Error Resume Next
    rs.close
    Set rs = Nothing
    strSQL = "DELETE * FROM tblTEMPFindingRover"
    CurrentDb.Execute strSQL, dbFailOnError + dbSeeChanges
   
    Exit Sub
PROC_ERR:
    If Err.Number = 2501 Then GoTo PROC_EXIT
    MsgBox "ERROR " & Err.Number & ": " & Err.Description
    GoTo PROC_EXIT
End Sub

Sub Activ4PetsExport(strDest As String)
    Dim strPath As String
    'Dim strZip As String
    Dim strTxt As String
    Dim strTo As String
    Dim strTitle As String
    Dim strMsg As String
    Dim strSQL As String

    Dim rs As DAO.Recordset
    Dim rsHistory As DAO.Recordset
    Dim i As Integer
   
    '*************  File paths Miriam **************************
    'strPath = "C:\Users\Surf\Documents\dbApps\PawTrax\FindingRoverFiles"
    'strZip = "C:\Users\Surf\Documents\dbApps\PawTrax\FindingRoverFiles\activ4pets.zip"
    'strTxt = "C:\Users\Surf\Documents\dbApps\PawTrax\FindingRoverFiles\activ4pets.xlsx"
    '******************************************************
   
    '*************  File paths Production **************************
    strPath = "C:\Paw Trax\FindingRoverFiles"
    'strZip = "C:\Paw Trax\FindingRoverFiles\activ4pets.zip"
    strTxt = "C:\Paw Trax\FindingRoverFiles\activ4pets.xlsx"
    '******************************************************
   
    On Error Resume Next
    DoCmd.Hourglass True
    If Dir(strPath & "\") & "" = "" Then
        MkDir strPath
    Else
        'Kill strZip
        Kill strTxt
       
    End If
    On Error GoTo PROC_ERR
   
    If DCount("*", "qryActiv4PetsUpdates") = 0 Then
        MsgBox "There are no new or updated records to send"
        GoTo PROC_EXIT
    End If
    'DoCmd.OpenReport "rptFindingRoverUpdates", acViewPreview
    '  Save report in PDF format, and open it for display
    'DoCmd.OutputTo acOutputReport, "activ4petsUpdates", acFormatPDF, strPath & "\" & Format(Now, "yyyymmddhhnnss") & "_FindingRover.pdf", True
    'DoCmd.OpenQuery "qryupdactiv4petsExport"
    'DoEvents

    ' strPath = strPath & "\FindingRover"
   
    ' Export query to csv and put it in a zip file
    'DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    'Zip strZip, strTxt
   
    ' ftp text file to finding rover
    'strPath = PathName & "\" & strAccount & ".txt"
    'DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    'Set objFTP = New FTP
    'With objFTP
    '    .SourceFile = strTxt
    '    .FtpURL = strTARGET
    '    .DestinationFile = "/Shelters/LASPCAProd/" & Format(Now, "yyyymmddhhnnss") & "_FindingRover" & ".txt"
    '    .AutoCreateRemoteDir = False
    '    .ConnectToFTPHost strAccount, strPassword
    '    .UploadFileToFTPServer
    'End With
     
    ExcelExport strTxt, "SoftSlip Info", "SELECT * FROM qryActiv4PetsToSend"
    ExcelExport strTxt, "Medical Procedures", "SELECT * FROM qryActiv4PetsProcedures"
    ExcelExport strTxt, "Medications And Vaccinations", "SELECT * FROM qryActiv4PetsMedications"
    ExcelExport strTxt, "Vet Notes", "SELECT * FROM qryActiv4PetsNotes"
   
    'MsgBox "Data sent to active4Pets"
    ' Attach Zip file to email
    ' 2015-10-22 -- replaced the email code with the above FTP code.
    'Zip strZip, strTxt
    strTitle = "SPCALA Paw Trax Export"
    strMsg = "See attached."
    SendEmail strDest, strMsg, strTitle, strTxt
   
   
    ' Update/Add changed or new records to history table
    strSQL = "SELECT * FROM qryActiv4PetsUpdates"
    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
    Do Until rs.RecordCount = 0 Or rs.EOF
        strSQL = "SELECT * FROM tblActiv4PetsHistory WHERE SoftSlip = '" & rs("SoftSlip") & "'"
        Set rsHistory = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
        With rsHistory
            If .RecordCount = 0 Then .AddNew Else .Edit
            For i = 0 To (rs.Fields.Count - 1)
                .Fields(i) = rs.Fields(i)
            Next
            !DateSent = Now()
            .Update
        End With
        rsHistory.close
        Set rsHistory = Nothing
        rs.MoveNext
    Loop
   
   
PROC_EXIT:
    DoCmd.Hourglass False
    Exit Sub
   
    On Error Resume Next


PROC_ERR:
    If Err.Number = 2501 Then GoTo PROC_EXIT
    MsgBox "ERROR " & Err.Number & ": " & Err.Description
    GoTo PROC_EXIT
End Sub

1. Do you have DAO360.DLL under C:\Program Files (x86)\Common Files\microsoft shared\DAO\
and here?
C:\Windows\SysWOW64\
C:\Windows\System32\

I've tried upload from Windows server 2012 R2 and Windows 7.  I've also tried access 2013 and 2016.

The site is ftp://spcala.com

DAO360.dll is only in the microsoft folder

Okay, copy the DAO360.dll from "C:\Program Files (x86)\Common Files\microsoft shared\DAO\" to C:\Windows\SysWOW64\  and C:\Windows\System32\ if the folders exist and try the ftp again. And report back.

copied files.  Same error

I also saw DAO350.dll in the Microsoft folder

Is it possible to reboot and try the FTP again?

sure

Looking over your code I noticed that in (MsgBox "Error " & Err.Number & " in cmdFTP_Click:" & vbCrLf & Err.Description) the cmdFTP_Click is not declared anywhere. Has the code changed before the issue occurred?

I rebooted my computer.  Same error.  Rebooting the server now would be very difficult, but if necessary I could do it.

To clarify the environment.  The front and backends are stored on a 2012 R2 server.  I've tried running the upload from the server and from my computer.

The server is using Access 2013.  My computer is running Access 2016.

Just to clarify, it worked on Friday

Let's leave the server alone because you mentioned that you are able to connect to it using Filezilla .

Open the app, open the VBA editor, and do a compile.

 Do you compile with no errors?

Jim.

No the code hasn't changed.  The only change is we went from 2013 to 2016.  Here is the code from a version backed up 10/21/17

Option Compare Database
Option Explicit

Private Sub cboLocation_AfterUpdate()
Me.Requery
End Sub

Private Sub cmdFTP_Click()

Dim strAccount As String
Dim strPassword As String
Dim strDest As String

Const conRover = "ftp://ftp.storagemadeeasy.com"
Const conActiv4Pets = "spcala@activ4pets.com"
On Error GoTo Proc_Error

' initialize paths for different locations

Select Case Me.cboLocation
    Case "Long Beach"
        strAccount = "CA366"
        strPassword = "4"
        SPCALAExport strAccount, strPassword
        Exit Sub
       
    Case "South Bay"
        strAccount = "CA1612"
        strPassword = "etz"
        SPCALAExport strAccount, strPassword
        Exit Sub
       
    Case "Pico Rivera"  ' Pico credentials.  Note that if the account is  Ca2356, the text file uploaded should be named Ca2353.txt (it should match the account) **********
        strAccount = "CA2356"
        strPassword = "m"
        SPCALAExport strAccount, strPassword
        Exit Sub

       
    Case "SPCALA Webpage"
        strAccount = "pawtrax2@spcala.com"
        strPassword = "2!@"
        SPCALAExport strAccount, strPassword
        Exit Sub

       
    Case "Finding Rover"
        strAccount = "laspca@findingrover"
        strPassword = "ndingR0ver"
        FindingRoverExport conRover, strAccount, strPassword
        Exit Sub
       
    Case "activ4pets"
        strDest = conActiv4Pets
        Activ4PetsExport (strDest)
        Exit Sub
   
    Case Else
        MsgBox "Please select Long Beach or South Bay as location, or select SPCALA Webpage"
        Exit Sub
End Select

PROC_EXIT:
    On Error Resume Next
    Exit Sub
   
Proc_Error:
    MsgBox "Error " & Err.Number & " in cmdFTP_Click:" & vbCrLf & Err.Description

    Resume PROC_EXIT

End Sub


Sub InitFTPObject(objFTP As FTP, strPath As String, strPage As String, strDest As String, strAccount As String, strPassword As String)
        With objFTP
            .SourceFile = strPath
            .FtpURL = strPage
            .DestinationFile = strDest
            .AutoCreateRemoteDir = False
            .ConnectToFTPHost strAccount, strPassword
            .UploadFileToFTPServer
        End With
End Sub

Private Sub SPCALAExport(strAccount As String, strPassword As String)
Dim objFTP As FTP
Dim strPath As String
Dim imgPath As String
Dim ftpPath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFail As DAO.Recordset
Dim ErrCount As Integer


Const conTARGET = "ftp://members.petfinder.com"
Const conRover = "ftp://ftp.storagemadeeasy.com"
Const conWEBPAGE = "ftp://spcala.com"
Const PathName = "\\databases\access2015\Petfinder"
On Error GoTo Proc_Error

' initialize progress tracking textboxes

Me!txtAvailable = Me.RecordsetClone.RecordCount
If Me.cboLocation = "SPCALA Webpage" Then
    Me!txtAvailable = DCount("*", "qryWebpageExport")
End If
Me!txtSent = 0
Me!txtNoPic = 0
Me!txtTotal = 0
ErrCount = 0




' export the query
If Me.cboLocation = "SPCALA Webpage" Then
    strPath = PathName & "\adoptable.txt"
    'Application.ExportXML ObjectType:=acExportQuery, _
    'DataSource:="qryWebpageExport", _
    'datatarget:=strPath
    DoCmd.TransferText acExportDelim, "Webpage Export Specification", _
      "qryWebpageExport", strPath, True

    Set objFTP = New FTP
    With objFTP
        .SourceFile = strPath
        .FtpURL = conWEBPAGE
        .DestinationFile = "adoptable.txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With


Else
    strPath = PathName & "\" & strAccount & ".txt"
    DoCmd.TransferText acExportDelim, "Petfinder Export Specification", "qryPetfinderExport", strPath, True
    Set objFTP = New FTP
    With objFTP
        .SourceFile = strPath
        .FtpURL = conTARGET
        .DestinationFile = "/import/" & strAccount & ".txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With
End If

'export all pictures

imgPath = DLookup("DefaultImagePath", "tbl_ImageDefaultPath", "ImageType='SoftSlips'")

Set db = CurrentDb
Set rsFail = db.OpenRecordset("tblPetfinderFailures", dbOpenDynaset)

If Me.cboLocation = "SPCALA Webpage" Then
    Set rs = db.OpenRecordset("qryWebpageExport", dbOpenDynaset)
Else
    Set rs = Me.RecordsetClone
End If
rs.MoveFirst
With objFTP
    If Me.cboLocation = "SPCALA Webpage" Then
        .FtpURL = conWEBPAGE
    Else
        .FtpURL = conTARGET
    End If
    .ConnectToFTPHost strAccount, strPassword
End With

' set initial ftp
If Me.cboLocation = "SPCALA Webpage" Then
    ftpPath = ""
Else
    ftpPath = "/import/photos/"
End If
Do Until rs.EOF
TryAgain:
    If Len(rs!SoftSlipPicPathFile & "") <> 0 Then
        If Dir(rs!SoftSlipPicPathFile) <> "" Then
            If Me.cboLocation <> "SPCALA Webpage" Then
                Me.Bookmark = rs.Bookmark
            End If
            With objFTP
                '.SourceFile = imgPath & "\" & rs!SoftSlip & ".jpg"
                .SourceFile = rs!SoftSlipPicPathFile
                .DestinationFile = ftpPath & rs!SoftSlip & ".jpg"
                .UploadFileToFTPServer
            End With
            ' since the focus is now on the photos folder, we don't need the path any more
            'If Me.cboLocation <> "SPCALA Webpage" Then
                ftpPath = ""
            'End If
            Me!txtUploading = rs!SoftSlip
            Me!txtSent = Me!txtSent + 1
        Else
            Me!txtNoPic = Me!txtNoPic + 1
        End If
    Else
        Me!txtNoPic = Me!txtNoPic + 1
    End If
    Me!txtTotal = Me!txtTotal + 1
    Me.Repaint
    rs.MoveNext
Loop
PROC_EXIT:
    On Error Resume Next
    Set objFTP = Nothing
    Exit Sub
   
Proc_Error:
    Select Case Err.Number
        Case -2147219289 ' FTP switching to binary
            'MsgBox "FTP switching to binary, retrying " & rs!SoftSlip
            ErrCount = ErrCount + 1
            If ErrCount < 6 Then
                With objFTP
                    If Me.cboLocation = "SPCALA Webpage" Then
                        .FtpURL = conWEBPAGE
                    Else
                        .FtpURL = conTARGET
                    End If
                    .ConnectToFTPHost strAccount, strPassword
                End With
                Resume TryAgain
            Else
                ' msgbox commented out per JR's request
                'MsgBox "Too many FTP errors for " & rs!SoftSlip & ", skipping to next picture"
                rsFail.AddNew
                    rsFail!SoftSlip = rs!SoftSlip
                    rsFail!faildate = Now
                rsFail.Update
               
                ErrCount = 0
                rs.MoveNext
                If rs.EOF Then
                    Resume PROC_EXIT
                Else
                    Resume TryAgain
                End If
            End If
        Case Else
            MsgBox "Error " & Err.Number & " in cmdFTP_Click:" & vbCrLf & Err.Description
    End Select
    Resume PROC_EXIT
End Sub



Private Sub Form_Current()
' Update image for this animal
Dim strPath As String
Dim strFile As String
On Error Resume Next
strPath = DLookup("DefaultImagePath", "tbl_ImageDefaultPath", "ImageType='SoftSlips'")
'strFile = strPath & "\" & Me!SoftSlip & ".jpg"
strFile = Nz(Me!SoftSlipPicPathFile, strPath & "\NoPicture.jpg")
If Dir(strFile) <> "" Then
    Me.imgAnimalPicture.Picture = strFile
End If

End Sub
Private Sub cmdClose_Click()
On Error GoTo Err_cmdclose_Click


    DoCmd.Close

Exit_cmdclose_Click:
    Exit Sub

Err_cmdclose_Click:
    MsgBox Err.Description
    Resume Exit_cmdclose_Click
   
End Sub

Sub FindingRoverExport(strTARGET As String, strAccount As String, strPassword As String)
    Dim strPath As String
    Dim strZip As String
    Dim strTxt As String
    Dim strTo As String
    Dim strTitle As String
    Dim strMsg As String
    Dim strSQL As String
    Dim rs As DAO.Recordset
    Dim rsHistory As DAO.Recordset
    Dim s As String
    Dim i As Integer
    Dim arrPic() As String
    Dim strRoverPicPath As String
    Dim strRoverPic As String
    Dim objFTP As FTP
   
    '*************  File paths **************************
    strRoverPicPath = "" & DLookup("Rover", "tblPaths")
    strPath = "C:\Paw Trax\FindingRoverFiles"
    strZip = "C:\Paw Trax\FindingRoverFiles\FindingRover.zip"
    strTxt = "C:\Paw Trax\FindingRoverFiles\FindingRover.txt"
    '******************************************************
   
    On Error Resume Next
    DoCmd.Hourglass True
    If Dir(strPath & "\") & "" = "" Then
        MkDir strPath
    Else
        Kill strZip
        Kill strTxt
       
    End If
    On Error GoTo PROC_ERR
   
    strSQL = "DELETE * FROM tblTEMPFindingRover"
    CurrentDb.Execute strSQL, dbFailOnError + dbSeeChanges
    Do Until DCount("*", "tblTEMPFindingRover") = 0
        DoEvents
    Loop
   
    If DCount("*", "qryFindingRoverUpdates") = 0 Then
        MsgBox "There are no new or updated records to send"
        GoTo PROC_EXIT
    End If
   
    'DoCmd.OpenReport "rptFindingRoverUpdates", acViewPreview
    '  Save report in PDF format, and open it for display
    DoCmd.OutputTo acOutputReport, "rptFindingRoverUpdates", acFormatPDF, strPath & "\" & Format(Now, "yyyymmddhhnnss") & "_FindingRover.pdf", True
    DoCmd.OpenQuery "qryupdFindingRoverExport"
    DoEvents
   
    strSQL = "SELECT SoftSlip, Pic, EncodedImage FROM tblTEMPFindingRover WHERE Pic & '' <> '' AND pic NOT LIKE '*NoImage*'"
    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
    Do Until rs.RecordCount = 0 Or rs.EOF
        'arrPic = Split(rs("Pic"), "\")
        arrPic = Split(rs("Pic"), "Pet-Ark\")
        strRoverPic = strRoverPicPath & arrPic(UBound(arrPic))
        s = Replace(Replace(ImageToBase64Encoded(strRoverPic), Chr(10), ""), Chr(13), "")
        If s <> "COULD NOT ENCODE SPECIFIED FILE" Then
            rs.Edit
            rs("EncodedImage") = s
            rs.Update
        End If
        rs.MoveNext
    Loop

   
   
    strPath = strPath & "\FindingRover"
   
    ' Export query to csv and put it in a zip file
    DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    Zip strZip, strTxt
   
    ' ftp text file to finding rover
    ' strPath = PathName & "\" & strAccount & ".txt"
    DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    Set objFTP = New FTP
    With objFTP
        .SourceFile = strTxt
        .FtpURL = strTARGET
        .DestinationFile = "/Shelters/LASPCAProd/" & Format(Now, "yyyymmddhhnnss") & "_FindingRover" & ".txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With
     
    MsgBox "Data sent to Finding Rover"
    ' Attach Zip file to email
    ' 2015-10-22 -- replaced the email code with the above FTP code.
    'strTo = ""
    'strTitle = "Finding Rover Files"
    'strMsg = "See attached."
    'SendEmail strTo, strMsg, strTitle, strZip
   
   
   
    ' Update/Add changed or new records to history table
    strSQL = "SELECT * FROM qryFindingRoverUpdates"
    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
    Do Until rs.RecordCount = 0 Or rs.EOF
        strSQL = "SELECT * FROM tblFindingRoverHistory WHERE SoftSlip = '" & rs("SoftSlip") & "'"
        Set rsHistory = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
        With rsHistory
            If .RecordCount = 0 Then .AddNew Else .Edit
            For i = 0 To (rs.Fields.Count - 1)
                .Fields(i) = rs.Fields(i)
            Next
            !DateSent = Now()
            .Update
        End With
        rsHistory.Close
        Set rsHistory = Nothing
        rs.MoveNext
    Loop
   
   
PROC_EXIT:

    DoCmd.Hourglass False
   
   
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    strSQL = "DELETE * FROM tblTEMPFindingRover"
    CurrentDb.Execute strSQL, dbFailOnError + dbSeeChanges
   
    Exit Sub
PROC_ERR:
    If Err.Number = 2501 Then GoTo PROC_EXIT
    MsgBox "ERROR " & Err.Number & ": " & Err.Description
    GoTo PROC_EXIT
End Sub

Sub Activ4PetsExport(strDest As String)
    Dim strPath As String
    'Dim strZip As String
    Dim strTxt As String
    Dim strTo As String
    Dim strTitle As String
    Dim strMsg As String
    Dim strSQL As String

    Dim rs As DAO.Recordset
    Dim rsHistory As DAO.Recordset
    Dim i As Integer
   
    '*************  File paths Miriam **************************
    'strPath = "C:\Users\Surf\Documents\dbApps\PawTrax\FindingRoverFiles"
    'strZip = "C:\Users\Surf\Documents\dbApps\PawTrax\FindingRoverFiles\activ4pets.zip"
    'strTxt = "C:\Users\Surf\Documents\dbApps\PawTrax\FindingRoverFiles\activ4pets.xlsx"
    '******************************************************
   
    '*************  File paths Production **************************
    strPath = "C:\Paw Trax\FindingRoverFiles"
    'strZip = "C:\Paw Trax\FindingRoverFiles\activ4pets.zip"
    strTxt = "C:\Paw Trax\FindingRoverFiles\activ4pets.xlsx"
    '******************************************************
   
    On Error Resume Next
    DoCmd.Hourglass True
    If Dir(strPath & "\") & "" = "" Then
        MkDir strPath
    Else
        'Kill strZip
        Kill strTxt
       
    End If
    On Error GoTo PROC_ERR
   
    If DCount("*", "qryActiv4PetsUpdates") = 0 Then
        MsgBox "There are no new or updated records to send"
        GoTo PROC_EXIT
    End If
    'DoCmd.OpenReport "rptFindingRoverUpdates", acViewPreview
    '  Save report in PDF format, and open it for display
    'DoCmd.OutputTo acOutputReport, "activ4petsUpdates", acFormatPDF, strPath & "\" & Format(Now, "yyyymmddhhnnss") & "_FindingRover.pdf", True
    'DoCmd.OpenQuery "qryupdactiv4petsExport"
    'DoEvents

    ' strPath = strPath & "\FindingRover"
   
    ' Export query to csv and put it in a zip file
    'DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    'Zip strZip, strTxt
   
    ' ftp text file to finding rover
    'strPath = PathName & "\" & strAccount & ".txt"
    'DoCmd.TransferText acExportDelim, "FindingRoverExport", "tblTEMPFindingRover", strTxt, True
    'Set objFTP = New FTP
    'With objFTP
    '    .SourceFile = strTxt
    '    .FtpURL = strTARGET
    '    .DestinationFile = "/Shelters/LASPCAProd/" & Format(Now, "yyyymmddhhnnss") & "_FindingRover" & ".txt"
    '    .AutoCreateRemoteDir = False
    '    .ConnectToFTPHost strAccount, strPassword
    '    .UploadFileToFTPServer
    'End With
     
    ExcelExport strTxt, "SoftSlip Info", "SELECT * FROM qryActiv4PetsToSend"
    ExcelExport strTxt, "Medical Procedures", "SELECT * FROM qryActiv4PetsProcedures"
    ExcelExport strTxt, "Medications And Vaccinations", "SELECT * FROM qryActiv4PetsMedications"
    ExcelExport strTxt, "Vet Notes", "SELECT * FROM qryActiv4PetsNotes"
   
    'MsgBox "Data sent to active4Pets"
    ' Attach Zip file to email
    ' 2015-10-22 -- replaced the email code with the above FTP code.
    'Zip strZip, strTxt
    strTitle = "SPCALA Paw Trax Export"
    strMsg = "See attached."
    SendEmail strDest, strMsg, strTitle, strTxt
   
   
    ' Update/Add changed or new records to history table
    strSQL = "SELECT * FROM qryActiv4PetsUpdates"
    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
    Do Until rs.RecordCount = 0 Or rs.EOF
        strSQL = "SELECT * FROM tblActiv4PetsHistory WHERE SoftSlip = '" & rs("SoftSlip") & "'"
        Set rsHistory = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
        With rsHistory
            If .RecordCount = 0 Then .AddNew Else .Edit
            For i = 0 To (rs.Fields.Count - 1)
                .Fields(i) = rs.Fields(i)
            Next
            !DateSent = Now()
            .Update
        End With
        rsHistory.Close
        Set rsHistory = Nothing
        rs.MoveNext
    Loop
   
   
PROC_EXIT:
    DoCmd.Hourglass False
    Exit Sub
   
    On Error Resume Next


PROC_ERR:
    If Err.Number = 2501 Then GoTo PROC_EXIT
    MsgBox "ERROR " & Err.Number & ": " & Err.Description
    GoTo PROC_EXIT
End Sub

<<What could be causing this.  >>

 At a guess, it's broken references, namely the FTP object your using.   But first see if you can compile without error.

Jim.

Compiles with no errors

OK, open the code again and put a stop in here:

' initialize paths for different locations

STOP

Select Case Me.cboLocation
    Case "Long Beach"

of cmdFTPClick.   Execute.    When you hit the stop, start executing the code step by step using F8.   Might take a while, but at some point you'll get to the point of the error.

It's difficult to pin down from looking at the code because not every procedure has error handling (which it should) in it.

The error refers to a piece of code that is trying to look at an object (a recordset or the FTP object) and that object is not a reference to anything

Jim.

"No the code hasn't changed.  The only change is we went from 2013 to 2016.  Here is the code from a version backed up 10/21/17"
Like Jim mentioned some references have changed when you moved from 2013 to 2016. It seems to be the cmdFTP_Click which is holding up the script.

Need more clarification.  I put the Stop in.  When I hit F8 nothing happens.

Private Sub cmdFTP_Click()

Dim strAccount As String
Dim strPassword As String
Dim strDest As String

Const conRover = "ftp://ftp.storagemadeeasy.com"
Const conActiv4Pets = "spcala@activ4pets.com"
On Error GoTo Proc_Error

' initialize paths for different locations

Stop

Select Case Me.cboLocation
    Case "Long Beach"
        strAccount = "CA366"
        strPassword = "dion54"
        SPCALAExport strAccount, strPassword
        Exit Sub

I was just looking at everything and it's probably related to this:

Dim objFTP As FTP

 When you went from A2013 to A2016, did you possibly move from 32 bit Access to 64 bit Access?

 You should still have the reference for whatever your using for FTP, but if you switched Office Editions, it won't work when called.

 Paste a screen shot of the references if you can (vba editor, Tools/References).   Also check File/Account for the version of Access that you have.

Jim.

<<Need more clarification.  I put the Stop in.  When I hit F8 nothing happens. >>

  You need to execute the form, click the button, and then the VBA editor will pop up and the STOP line will be highlighted.

 From there, you can continue code execution one line at a time using F8.

F5 will continue execution with no stepping.

Jim.

These are the only ones checked.  Office Professional Plus 2016

I stepped through the code, but didn't see anything that was obvious as an error.  What would I be looking for?

I just realized I didn't step all the way through.  The error pops up here.

We are still using 32 bit Access

The error is in this section

Private Sub SPCALAExport(strAccount As String, strPassword As String)

OK, but just prior to that, when did you jump to here:

<<Proc_Error:
    Select Case Err.Number
        Case -2147219289 ' FTP switching to binary>>

  Which is the start of the error handling.   What your looking for is the line that causes you to jump to the error handler.

<<The error is in this section>>

  Move the stop to there and step through again.

Jim.

it happens here.  2nd line from the bottom

Private Sub SPCALAExport(strAccount As String, strPassword As String)
Dim objFTP As FTP
Dim strPath As String
Dim imgPath As String
Dim ftpPath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFail As DAO.Recordset
Dim ErrCount As Integer

Stop

Const conTARGET = "ftp://members.petfinder.com"
Const conRover = "ftp://ftp.storagemadeeasy.com"
Const conWEBPAGE = "ftp://spcala.com"
Const PathName = "\\databases\access2015\Petfinder"
On Error GoTo Proc_Error

' initialize progress tracking textboxes

Me!txtAvailable = Me.RecordsetClone.RecordCount
If Me.cboLocation = "SPCALA Webpage" Then
    Me!txtAvailable = DCount("*", "qryWebpageExport")
End If
Me!txtSent = 0
Me!txtNoPic = 0
Me!txtTotal = 0
ErrCount = 0




' export the query
If Me.cboLocation = "SPCALA Webpage" Then
    strPath = PathName & "\adoptable.txt"
    'Application.ExportXML ObjectType:=acExportQuery, _
    'DataSource:="qryWebpageExport", _
    'datatarget:=strPath
    DoCmd.TransferText acExportDelim, "Webpage Export Specification", _
      "qryWebpageExport", strPath, True

    Set objFTP = New FTP
    With objFTP
        .SourceFile = strPath
        .FtpURL = conWEBPAGE
        .DestinationFile = "adoptable.txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With


Else
    strPath = PathName & "\" & strAccount & ".txt"
    DoCmd.TransferText acExportDelim, "Petfinder Export Specification", "qryPetfinderExport", strPath, True
    Set objFTP = New FTP
    With objFTP
        .SourceFile = strPath
        .FtpURL = conTARGET
        .DestinationFile = "/import/" & strAccount & ".txt"
        .AutoCreateRemoteDir = False
        .ConnectToFTPHost strAccount, strPassword
        .UploadFileToFTPServer
    End With
End If

'export all pictures

imgPath = DLookup("DefaultImagePath", "tbl_ImageDefaultPath", "ImageType='SoftSlips'")

Set db = CurrentDb
Set rsFail = db.OpenRecordset("tblPetfinderFailures", dbOpenDynaset)

If Me.cboLocation = "SPCALA Webpage" Then
    Set rs = db.OpenRecordset("qryWebpageExport", dbOpenDynaset)
Else
    Set rs = Me.RecordsetClone
End If
rs.MoveFirst
With objFTP
    If Me.cboLocation = "SPCALA Webpage" Then
        .FtpURL = conWEBPAGE
    Else
        .FtpURL = conTARGET
    End If
    .ConnectToFTPHost strAccount, strPassword
End With

' set initial ftp
If Me.cboLocation = "SPCALA Webpage" Then
    ftpPath = ""
Else
    ftpPath = "/import/photos/"
End If
Do Until rs.EOF
TryAgain:
    If Len(rs!SoftSlipPicPathFile & "") <> 0 Then
        If Dir(rs!SoftSlipPicPathFile) <> "" Then
            If Me.cboLocation <> "SPCALA Webpage" Then
                Me.Bookmark = rs.Bookmark
            End If
            With objFTP
                '.SourceFile = imgPath & "\" & rs!SoftSlip & ".jpg"
                .SourceFile = rs!SoftSlipPicPathFile
                .DestinationFile = ftpPath & rs!SoftSlip & ".jpg"
                .UploadFileToFTPServer
            End With
            ' since the focus is now on the photos folder, we don't need the path any more
            'If Me.cboLocation <> "SPCALA Webpage" Then
                ftpPath = ""
            'End If
            Me!txtUploading = rs!SoftSlip
            Me!txtSent = Me!txtSent + 1
        Else
            Me!txtNoPic = Me!txtNoPic + 1
        End If
    Else
        Me!txtNoPic = Me!txtNoPic + 1
    End If
    Me!txtTotal = Me!txtTotal + 1
    Me.Repaint
    rs.MoveNext
Loop
PROC_EXIT:
    On Error Resume Next
    Set objFTP = Nothing
    Exit Sub
   
Proc_Error:
    Select Case Err.Number
        Case -2147219289 ' FTP switching to binary
            'MsgBox "FTP switching to binary, retrying " & rs!SoftSlip
            ErrCount = ErrCount + 1
            If ErrCount < 6 Then
                With objFTP
                    If Me.cboLocation = "SPCALA Webpage" Then
                        .FtpURL = conWEBPAGE
                    Else
                        .FtpURL = conTARGET
                    End If
                    .ConnectToFTPHost strAccount, strPassword
                End With
                Resume TryAgain
            Else
                ' msgbox commented out per JR's request
                'MsgBox "Too many FTP errors for " & rs!SoftSlip & ", skipping to next picture"
                rsFail.AddNew
                    rsFail!SoftSlip = rs!SoftSlip
                    rsFail!faildate = Now
                rsFail.Update
               
                ErrCount = 0
                rs.MoveNext
                If rs.EOF Then
                    Resume PROC_EXIT
                Else
                    Resume TryAgain
                End If
            End If
        Case Else
           MsgBox "Error " & Err.Number & " in cmdFTP_Click:" & vbCrLf & Err.Description
    End Select

<<it happens here.  2nd line from the bottom>>

  No, getting there is a result of hitting an error.   The bottom of that procedure, including the second line from the bottom is all error handling code.

  As your stepping through the code, you'll try to execute a line, and then all of a sudden it will jump to here:

 Proc_Error:
    Select Case Err.Number

 Which is the start of the error handling code.    What should be happening if everything was working correctly is that you would step through the entire procedure until you hit this:

PROC_EXIT:
    On Error Resume Next
    Set objFTP = Nothing
    Exit Sub

 which is the normal exit and you would never jump to here:

Proc_Error:
    Select Case Err.Number

 or execute any of the code below that line.


Jim.

First off thank you for helping.  This is critical to us.  We are the Society for the Prevention of Cruelty to Animals Los Angeles.  This upload sends all of our animal information to our web site.  So when it's not working everything is outdated

I'm not a VBA programmer, so I need your help.   I don't understand when you say  As your stepping through the code, you'll try to execute a line, and then all of a sudden it will jump to here:

I see that you charge for your services.  Could you fix this if you had the database?  We don't have a lot of money, but I could get some approved for this.

Ah, this is the DB then that Miriam Bizup worked on.

 I really don't have the time, but if nothing's been done other than moving to A2016 and it is still 32 bit, then it should be a fast fix ( actually don't understand why it broke).   The fastest thing would be for me to remote in.  

  I'll send you a Private message in a minute with my phone number.

  Give me a call and we'll discuss.

Jim.

Yes.  Miriam is a HUGE help, but not available at this time.

Thanks, again for all the help