(图片来源网络,侵删)
Access快速开发平台通用附件的图片用共享文件夹的方式,安全性能不高,可能存在误删除。把图片文件用FTP的方法保存,在客户端开通FTP即可实现通用附件的FTP网络服务器实时共享。优点是扩大了服务器的应用范围,缺点是每次浏览都要重新下载更新图片文件,性能不如共享。一、企业版:设置开发平台FTP:专业版在系统表 Sys_ServerParameters 手工增加以下内容即可。二、复制上传,下载自定义函数代码到“模块”。三、在 通用附件窗体(SysFrmAttachments) 下新增红字调用函数代码:代码所在位置请自行对应。四、架设FTP服务器方法请自行查找。1、保存事件Public Function SaveAttachmentData(DataCategory As String _ , DataID As Variant _ , Optional ActiveConnection As Variant _ )‘中间部分省略 rst![AttachmentName] = rstTmp![AttachmentName] uploadFTPfile rstTmp![AttachmentName] '上传到FTP rst.Update‘中间部分省略2、加载浏览事件Public Function LoadAttachmentData(DataCategory As String _ , DataID As Variant _ , Optional ActiveConnection As Variant _ )‘中间部分省略 rstTmp![AttachmentName] = rst![AttachmentName] downloadFTPfile rst![AttachmentName] '下载FTP到本地 rstTmp.Update‘中间部分省略附上传及下载函数:Function downloadFTPfile(downFILEname As String) As Boolean On Error GoTo ErrorHandler '下载 FTP 文件 If getParameter(\"FTP Server Address\", dbText, \"\", , , True) = \"\" Then GoTo ExitHere Dim AttPATH As String '本地保存路径设置 AttPATH = getParameter(\"Attachment Path\", dbText, \"\", , , True) If Len(AttPATH) = 0 Then AttPATH = CurrentProject.Path & \"\Attachments\\" If Left(AttPATH, 2) = \".\\" Then AttPATH = CurrentProject.Path & Mid(AttPATH, 2) If Right(AttPATH, 1) <> \"\\" Then AttPATH = AttPATH & \"\\" If dir(AttPATH)=\"\" then mkdir(AttPATH) With FTPServer .OpenConnection ‘专业版需直接使用参数 getParameter(\"FTP Server Address\", dbText, \"\", , , True),getParameter(\"FTP Server Port\", dbText, \"\", , , True),getParameter(\"FTP Server Username\", dbText, \"\", , , True),getParameter(\"FTP Server Password\", dbText, \"\", , , True) If .FileExists(\"Attachments\\" & downFILEname) Then .DownloadFile \"Attachments\\" & downFILEname, AttPATH & downFILEname .CloseConnection End WithExitHere: downloadFTPfile = True Exit FunctionErrorHandler: downloadFTPfile = FalseEnd FunctionFunction uploadFTPfile(upFILEname As String) As Boolean On Error GoTo ErrorHandler '上传 FTP 文件 If getParameter(\"FTP Server Address\", dbText, \"\", , , True) = \"\" Then GoTo ExitHere Dim AttPATH As String '本地保存路径设置 AttPATH = getParameter(\"Attachment Path\", dbText, \"\", , , True) If Len(AttPATH) = 0 Then AttPATH = CurrentProject.Path & \"\Attachments\\" If Left(AttPATH, 2) = \".\\" Then AttPATH = CurrentProject.Path & Mid(AttPATH, 2) If Right(AttPATH, 1) <> \"\\" Then AttPATH = AttPATH & \"\\" With FTPServer .OpenConnection ‘专业版需直接使用参数 getParameter(\"FTP Server Address\", dbText, \"\", , , True),getParameter(\"FTP Server Port\", dbText, \"\", , , True),getParameter(\"FTP Server Username\", dbText, \"\", , , True),getParameter(\"FTP Server Password\", dbText, \"\", , , True) '判断FTP是否存在Attachments文件夹 If .FileExists(\"Attachments\") = False Then .CreateDirectory \"Attachments\" If Dir(AttPATH & upFILEname) <> \"\" Then .UploadFile AttPATH & upFILEname, \"Attachments\\" & upFILEname .CloseConnection End WithExitHere: uploadFTPfile = True Exit FunctionErrorHandler: uploadFTPfile = FalseEnd Function
0 评论