Access开发平台--让通用附件模块支持ftp

时　间:2016-04-25 09:09:55
作　者:宽一   ID：17481  城市：廊坊
摘　要:改进了开发平台的通用附件模块，让模块支持FTP存储与显示
正　文:

用access快速开发平台，非常好用，感谢各位老师的辛勤劳动。

在平台老师的热心提示下，我改进了开发平台的通用附件模块，让模块支持FTP存储与显示，现将思路和代码共享如下：

1、思路，本地附件文件夹和ftp附件文件夹结合

   a、存储，先存储到本地文件夹，同时查询ftp文件夹是否存在附件文件，如果不存在，则上传到ftp附件文件夹。

   b、显示，如果本地附件文件夹不存在所需附件，则从ftp下载到本地。

2、代码

Public Function LoadAttachmentData(DataCategory As String _
                                 , DataID As Variant _
                                 , Optional ActiveConnection As Variant _
                                   )
    On Error GoTo ErrorHandler

    Me.txtDataCategory.Tag = DataCategory
    Me.txtDataID.Tag = Nz(DataID)
    Dim strsql As String: strsql = " Select * FROM [Sys_Attachments]" _
                                 & " Where [DataCategory]='" & DataCategory & "' AND DataID='" & DataID & "'"
    Dim rst As Object
    If IsMissing(ActiveConnection) Then
        Set rst = OpenADORecordset(strsql, , CurrentProject.Connection)
    Else
        Set rst = OpenADORecordset(strsql, , ActiveConnection)
    End If
    Me.OnCurrent = ""
    Me.RecordSource = Replace(strsql, "[Sys_Attachments]", "[TMP_Attachments]")
    Dim rstTmp As Object: Set rstTmp = Me.Recordset
    Do Until rstTmp.EOF
        rstTmp.Delete
        rstTmp.MoveNext
    Loop

    If getParameter("FTP Attachment Path", dbText, "", , , True) <> "" Then
        fTPServer.OpenConnection   ''这里打开平台设置的ftp，但在我哪里好像有问题，我是把ftp参数写到这里，则没有问题

    End If



    Do Until rst.EOF
        rstTmp.AddNew
        rstTmp![DataCategory] = rst![DataCategory]
        rstTmp![DataID] = rst![DataID]
        rstTmp![AttachmentName] = rst![AttachmentName]

        If Dir(Me.txtAttachmentPath & rst!AttachmentName) <> "" Then
        Else

            ''如果不存在本地附件文件，则从FTP下载
            If getParameter("FTP Attachment Path", dbText, "", , , True) <> "" Then
                If fTPServer.FileExists(getParameter("FTP Attachment Path", dbText, "", , , True) & "\" & rst![AttachmentName]) Then
                    fTPServer.DownloadFile getParameter("FTP Attachment Path", dbText, "", , , True) & "\" & rst![AttachmentName], Me.txtAttachmentPath & rst!AttachmentName
                End If
            End If

        End If

        rstTmp.Update
        rst.MoveNext
    Loop
    rst.Close


    If getParameter("FTP Attachment Path", dbText, "", , , True) <> "" Then
        fTPServer.CloseConnection
    End If

ExitHere:
    Me.OnCurrent = "[Event Procedure]"
    Me.Requery
    Set rst = Nothing
    Set rstTmp = Nothing
    Exit Function

ErrorHandler:
    RDPErrorHandler Me.name & ": Function LoadAttachmentData()"
    Resume ExitHere
End Function

Public Function SaveAttachmentData(DataCategory As String _
                                 , DataID As Variant _
                                 , Optional ActiveConnection As Variant _
                                   )
    On Error GoTo ErrorHandler

    Dim strsql As String
    strsql = "Select * FROM [Sys_Attachments] Where [DataCategory]='" & DataCategory & "' AND DataID='" & DataID & "'"
    Dim rst As Object
    If IsMissing(ActiveConnection) Then
        Set rst = OpenADORecordset(strsql, adLockOptimistic, CurrentProject.Connection)
    Else
        Set rst = OpenADORecordset(strsql, adLockOptimistic, ActiveConnection)
    End If
    Do Until rst.EOF
        rst.Delete
        rst.MoveNext
    Loop

    If Me.txtDataID.Tag <> DataID Then
        Me.Requery
        Dim rstTmp As Object: Set rstTmp = Me.Recordset


        Do Until rstTmp.EOF
            Dim strNewName As String: strNewName = DataID & mid(rstTmp!AttachmentName, Len(Me.txtDataID.Tag) + 1)
            If Dir(Me.txtAttachmentPath & rstTmp!AttachmentName) <> "" Then

                If Len(Me.txtDataID.Tag) = 38 And Me.txtDataID.Tag Like "{*}" Then
                    Name Me.txtAttachmentPath & rstTmp!AttachmentName As Me.txtAttachmentPath & strNewName
                Else
                    CopyFile Me.txtAttachmentPath & rstTmp!AttachmentName, Me.txtAttachmentPath & strNewName
                End If
            End If

            rstTmp.Edit
            rstTmp!AttachmentName = strNewName
            rstTmp.Update
            rstTmp.MoveNext
        Loop
    End If
    Me.refresh

    If getParameter("FTP Attachment Path", dbText, "", , , True) <> "" Then
        fTPServer.OpenConnection ''如果有问题，请直接写入ftp参数
    End If

    Set rstTmp = Me.Recordset.Clone
    Do Until rstTmp.EOF
        rst.AddNew
        rst![DataCategory] = DataCategory
        rst![DataID] = DataID
        rst![AttachmentName] = rstTmp![AttachmentName]


        If getParameter("FTP Attachment Path", dbText, "", , , True) <> "" Then  ''如果需要使用ftp存储的话
            If fTPServer.FileExists(getParameter("FTP Attachment Path", dbText, "", , , True) & "\" & rstTmp![AttachmentName]) Then
            Else

                ''如果ftp上面不存在附件文件，则上传到ftp，避免重复上传
                fTPServer.UploadFile Me.txtAttachmentPath & rstTmp![AttachmentName], getParameter("FTP Attachment Path", dbText, "", , , True) & "\" & rstTmp![AttachmentName]
            End If
        End If

        rst.Update
        rstTmp.MoveNext
    Loop
    rst.Close

    If getParameter("FTP Attachment Path", dbText, "", , , True) <> "" Then
        fTPServer.CloseConnection
    End If

ExitHere:
    Set rst = Nothing
    Set rstTmp = Nothing
    Exit Function

ErrorHandler:
    RDPErrorHandler Me.name & ": Function SaveAttachmentData()"
    Resume ExitHere
End Function