Access培训
网站公告
·Access专家课堂QQ群号:239158550    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群!    ·如何快速搜索本站文章|示例|资料    
您的位置: 首页 > 技术文章 > Access开发平台

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


Access快速开发平台QQ群 (群号:239158550)       access源码网店

最新评论 查看更多评论(3)

2020/11/19 20:35:45王汪汪
这样的操作系统慢吗?

2019/4/22 13:04:27月皓星隐
收藏了,写的好

2016/5/5 14:37:50朱亮
感谢你啊,我研究了一会,也能用了,你说的“这里打开平台设置的ftp,但在我哪里好像有问题,我是把ftp参数写到这里,则没有问题”我也有这个问题,有空一起交流一下,我的QQ52974178

发表评论您的评论将提升作者分享的动力!快来评论一下吧!

用户名:
密 码:
内 容:
 

常见问答

技术分类

相关资源

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助