用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