Office2010 代码创建、另存、删除附件

Grant

用了一天时间写成了这个东西,准备融入到客户管理软件中去,现在很多客户电脑都安装了新的office2010
不得不转型学习office2010的新功能,发现有不少好东西,暂时先研究这个,先贴上来给大家分享一下

1. 
   
2. Option Compare Database
   
3. 
   
4.     '===============================================================================
   
5.     '-函数名称:         modAdj
   
6.     '-功能描述:         保存,删除,添加附件
   
7.     '-输入参数说明:     参数1:strPath As String 目标路径
   
8.     '                   参数2:strFileName As String 文件名称
   
9.     '                   参数3:ID As long    自动编号
   
10.     '-使用语法示例:     AddAdj(自动编号,文件名,路径)    '添加附件
    
11.     '                   DelAdj(自动编号,文件名)         '删除附件
    
12.     '                   GetAdj(自动编号,列表框)         '读取附件
    
13.     '                   GetSave(自动编号,文件名,路径)   '保存附件
    
14.     '-参考:
    
15.     '-使用注意:
    
16.     '-兼容性:           Office2007,Office2010
    
17.     '-作者:             Grant
    
18.     '-联系方式:         QQ:20991943  Email:20991943@qq.com
    
19.     '-更新日期：        2012-01-11
    
20.     '===============================================================================
    
21.   Public Function AddAdj(ID As Long, strFileName As String, strPath As String)  '添加附件
    
22.     Dim db As Database
    
23.     Dim Rstable As Recordset
    
24.     Dim RsAdj As Recordset2
    
25.    
    
26.     '数据库
    
27.     Set db = DBEngine.Workspaces(0).Databases(0)
    
28.    
    
29.     '打开表
    
30.     Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID)
    
31. 
    
32. '    While Not Rstable.EOF
    
33. 
    
34.         '获取附件列的文件集合
    
35.         Set RsAdj = Rstable("附件").Value
    
36.         '往附件列添加文件
    
37.         Rstable.Edit
    
38.         RsAdj.AddNew
    
39.         RsAdj("FileData").LoadFromFile (strPath)
    
40.         RsAdj("FileName") = strFileName
    
41.         RsAdj.Update
    
42.         Rstable.Update
    
43.         Rstable.Close
    
44. 
    
45.   End Function
    
46. 
    
47.   Public Function DelAdj(ID As Long, strFileName As String) '添加附件
    
48.     Dim db As Database
    
49.     Dim Rstable As Recordset
    
50.     Dim RsAdj As Recordset2
    
51.    
    
52.     '数据库
    
53.     Set db = DBEngine.Workspaces(0).Databases(0)
    
54.    
    
55.     '打开表
    
56.     Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID)
    
57. 
    
58. '    While Not Rstable.EOF
    
59. 
    
60.         '获取附件列的文件集合
    
61.         Set RsAdj = Rstable("附件").Value
    
62.         '往附件列添加文件
    
63.         Rstable.Edit
    
64.         While Not RsAdj.EOF
    
65.         
    
66.             If RsAdj("FileName") = strFileName Then
    
67.                 Rstable.Edit
    
68.                 RsAdj.Delete
    
69.                 Rstable.Update
    
70.                 Rstable.Close
    
71.                 Exit Function
    
72.             End If
    
73.             RsAdj.MoveNext
    
74.         Wend
    
75.         Rstable.Close
    
76.   End Function
    
77. 
    
78. Public Function GetAdj(ID As Long, list As ListBox) '获取附件,读取到list
    
79.     Dim db As Database
    
80.     Dim Rstable As Recordset
    
81.     Dim RsAdj As Recordset2
    
82. 
    
83.     Set db = DBEngine.Workspaces(0).Databases(0)    '数据库
    
84.     Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID) '定位表记录
    
85. 
    
86.     If Rstable.RecordCount = 0 Then Exit Function     '记录为0退出
    
87.         
    
88.         Set RsAdj = Rstable("附件").Value
    
89.         While Not RsAdj.EOF                  '循环
    
90.           list.AddItem RsAdj("FileName")    '读取文件到列表
    
91.         ' RsAdj("FileData").SaveToFile ("C:\Documents" & rsatts("FileName").Value)
    
92.           RsAdj.MoveNext
    
93.         Wend
    
94.         
    
95.     Rstable.Close
    
96.    
    
97. End Function
    
98. 
    
99. Public Function GetSave(ID As Long, strFileName As String, strPath As String)
    
100.     Dim db As Database
     
101.     Dim Rstable As Recordset
     
102.     Dim RsAdj As Recordset2
     
103.    
     
104.     '数据库
     
105.     Set db = DBEngine.Workspaces(0).Databases(0)
     
106.    
     
107.     '打开表
     
108.     Set Rstable = db.OpenRecordset("select * from 企业信息 where ID=" & ID)
     
109. 
     
110.         Set RsAdj = Rstable("附件").Value
     
111. 
     
112.         While Not RsAdj.EOF
     
113.         
     
114.             If RsAdj("FileName") = strFileName Then
     
115.                 If Dir(strPath) <> "" Then
     
116.                     Kill strPath
     
117.                 End If
     
118.                
     
119.                 RsAdj("FileData").SaveToFile (strPath)
     
120.                 Rstable.Close
     
121.                 Exit Function
     
122.             End If
     
123.             RsAdj.MoveNext
     
124.         Wend
     
125.         Rstable.Close
     
126. End Function
     
127. 
     

复制代码

游客，如果您要查看本帖隐藏内容请回复

JosephTan

看一下。

yanwei82123300

谢谢分享！

godzhong

好东西,先学习下

todaynew

建议将增改删独立成为函数

Grant

todaynew 发表于 2012-1-11 17:20
建议将SQL语句作为参数

是的,这个只是初版,很多地方需要完善,本来还想加入写图形进行美化,不过想想控制不便所以暂时先不加入

zhuyiwen

呵呵，附件，好东西

咱家是猫

我又回来啦.{:soso_e113:}

andymark

谢谢分享！！

sxb2007

谢谢分享！！