Office2010 代码创建、另存、删除附件 - Office中国论坛/Access中国论坛

Option Compare Database
'===============================================================================
'-函数名称: modAdj
'-功能描述: 保存,删除,添加附件
'-输入参数说明: 参数1:strPath As String 目标路径
' 参数2:strFileName As String 文件名称
' 参数3:ID As long 自动编号
'-使用语法示例: AddAdj(自动编号,文件名,路径) '添加附件
' DelAdj(自动编号,文件名) '删除附件
' GetAdj(自动编号,列表框) '读取附件
' GetSave(自动编号,文件名,路径) '保存附件
'-参考:
'-使用注意:
'-兼容性: Office2007,Office2010
'-作者: Grant
'-联系方式: QQ:20991943 Email:20991943@qq.com
'-更新日期： 2012-01-11
'===============================================================================
Public Function AddAdj(ID As Long, strFileName As String, strPath As String) '添加附件
Dim db As Database
Dim Rstable As Recordset
Dim RsAdj As Recordset2
'数据库
Set db = DBEngine.Workspaces(0).Databases(0)
'打开表
Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID)
' While Not Rstable.EOF
'获取附件列的文件集合
Set RsAdj = Rstable("附件").Value
'往附件列添加文件
Rstable.Edit
RsAdj.AddNew
RsAdj("FileData").LoadFromFile (strPath)
RsAdj("FileName") = strFileName
RsAdj.Update
Rstable.Update
Rstable.Close
End Function
Public Function DelAdj(ID As Long, strFileName As String) '添加附件
Dim db As Database
Dim Rstable As Recordset
Dim RsAdj As Recordset2
'数据库
Set db = DBEngine.Workspaces(0).Databases(0)
'打开表
Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID)
' While Not Rstable.EOF
'获取附件列的文件集合
Set RsAdj = Rstable("附件").Value
'往附件列添加文件
Rstable.Edit
While Not RsAdj.EOF
If RsAdj("FileName") = strFileName Then
Rstable.Edit
RsAdj.Delete
Rstable.Update
Rstable.Close
Exit Function
End If
RsAdj.MoveNext
Wend
Rstable.Close
End Function
Public Function GetAdj(ID As Long, list As ListBox) '获取附件,读取到list
Dim db As Database
Dim Rstable As Recordset
Dim RsAdj As Recordset2
Set db = DBEngine.Workspaces(0).Databases(0) '数据库
Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID) '定位表记录
If Rstable.RecordCount = 0 Then Exit Function '记录为0退出
Set RsAdj = Rstable("附件").Value
While Not RsAdj.EOF '循环
list.AddItem RsAdj("FileName") '读取文件到列表
' RsAdj("FileData").SaveToFile ("C:\Documents" & rsatts("FileName").Value)
RsAdj.MoveNext
Wend
Rstable.Close
End Function
Public Function GetSave(ID As Long, strFileName As String, strPath As String)
Dim db As Database
Dim Rstable As Recordset
Dim RsAdj As Recordset2
'数据库
Set db = DBEngine.Workspaces(0).Databases(0)
'打开表
Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID)
Set RsAdj = Rstable("附件").Value
While Not RsAdj.EOF
If RsAdj("FileName") = strFileName Then
If Dir(strPath) <> "" Then
Kill strPath
End If
RsAdj("FileData").SaveToFile (strPath)
Rstable.Close
Exit Function
End If
RsAdj.MoveNext
Wend
Rstable.Close
End Function

复制代码