好几年前写的, 现从CSDN博客中转移过来.
FSO操作
1
'此函数从字符串中分离出路径
2Public Function ParsePath(sPathIn As String) As String
3Dim i As Integer
4For i = Len(sPathIn) To 1 Step -1
5 If InStr(":\", Mid$(sPathIn, i, 1)) Then Exit For
6Next
7ParsePath = Left$(sPathIn, i)
8End Function
9
10'此函数从字符串中分离出文件名
11Public Function ParseFileName(sFileIn As String) As String
12Dim i As Integer
13For i = Len(sFileIn) To 1 Step -1
14 If InStr("\", Mid$(sFileIn, i, 1)) Then Exit For
15Next
16ParseFileName = Mid$(sFileIn, i + 1, Len(sFileIn) - i)
17End Function
18
19Public Sub openExcel(path As String) 'path表示需要打开的Excel文件的路径
20 '调用EXCEL打开产生的EXCEL表格,不需要预先知道程序安装,存放路径
21 'Shell "E:\Program Files\Office 2003\Office11\EXCEL.EXE D:\Excel.xls", vbMaximizedFocus
22 On Error GoTo errlabel
23 Dim MyXlsApp As Object '
24 Set MyXlsApp = CreateObject("Excel.Application") 'App.Path & "\EXCEL.xls"
25 MyXlsApp.Workbooks.Open filename:=path '', Password:="123", ReadOnly:=False,如果文件设置了密码,需要提供密码,可以设置文件打开方式,只读方式
26 MyXlsApp.Visible = True '设置Excel成为可见
27 Set MyXlsApp = Nothing '释放对象
28 Exit Sub
29errlabel:
30 MsgBox "无法打开指定的Excel文件,有可能你的电脑中没有" & _
31 "安装Excel或者指定的文件不存在!", vbCritical, "打开Excel文件" + ParseFileName(path) + "出错提示"
32End Sub
33
34Public Sub openWord(path As String) 'path表示需要打开的Word文件的路径
35 '调用Word打开产生的Word文档，不需要预先知道程序安装,存放路径
36 On Error GoTo errlabel
37 Dim word As New word.Application
38 word.Documents.Open filename:=path
39 word.Visible = True '设置word成为可见
40 Set word = Nothing '释放对象
41 Exit Sub
42errlabel:
43 MsgBox "无法打开指定的Word文档,有可能你的电脑中没有" & _
44 "安装Word或者指定的文件不存在!", vbCritical, "打开Word文件" + ParseFileName(path) + "出错提示"
45End Sub
46
47Public Sub CreateAccess(filename As String)
48On Error Resume Next
49Dim obj As New FileSystemObject
50If Not obj.FileExists(filename) Then
51Dim Access As New Access.Application
52Access.NewCurrentDatabase (filename)
53Access.DoCmd.RunSQL ("create table table1 (empty text(20));")
54Access.DoCmd.Save acDefault
55Access.Quit acQuitSaveAll
56End If
57End Sub
58
59'===========================================================================================
60'函数checkDir()用来检查当前程序所在目录下,是否存在下列文件夹Backup,Images,Docs,Report,Upload
61'Backup--------------存放数据库备份文件
62'Images--------------存放干部的照片
63'Docs----------------存放干部的审判材料
64'Report--------------存放生成的各种报表文件
65'Upload--------------存放导出的上报文件
66'===========================================================================================
67Public Sub checkDir(dir() As String)
68On Error Resume Next
69Dim obj As New FileSystemObject
70Dim i As Integer
71For i = LBound(dir) To UBound(dir) Step 1
72If Not obj.FolderExists(App.path + dir(i)) Then
73obj.CreateFolder App.path + dir(i)
74End If
75Next i
76End Sub
77
78'判断字符串中是否含有空格,单引号,双引号等特殊字符
79Public Function checkInput(iStr As String) As Boolean
80If InStr(iStr, " ") > 0 Or InStr(iStr, "'") > 0 Or InStr(iStr, """") > 0 Then
81checkInput = False
82Exit Function
83Else
84checkInput = True
85Exit Function
86End If
87End Function
88
89'FSO的几个应用函数
90
91'1.读取文件中所有字符的函数
92'其实就是通过ReadLine（读取行），通过 While Not cnrs.AtEndOfStream 的条件进行循环读取行，
93'来达到读取文件中所有字符。当然也可以使用ReadAll代替多个ReadLine，但主要缺点是将格式进行换行等问题需要再次解决。
94'引用函数 call FSOFileRead("xxx文件") 即可
95
96Function FileReadAll(filename As String) As String
97On Error GoTo errlabel
98Dim fso As New FileSystemObject
99If Not fso.FileExists(filename) Then
100FileReadAll = ""
101Exit Function
102Else
103Dim cnrs As TextStream
104Dim rsline As String
105rsline = ""
106Set cnrs = fso.OpenTextFile(filename, 1)
107While Not cnrs.AtEndOfStream
108rsline = rsline & cnrs.ReadLine
109Wend
110FileReadAll = rsline
111Exit Function
112End If
113errlabel:
114FileReadAll = ""
115End Function
116
117'2读取文件中某一行中所有字符的函数
118'这次即使用了readall方法，通过split函数将读取的内容以换行为条件，进行数组的定义，
119'提取 lineNum-1（数组从0记数） 所对应的数组值即为 读取的该行值 ，也就是该行中所有的字符了。
120'函数的调用 call FSOlinedit("xxx文件",35) 表示显示xxx文件的第35行内容
121
122Function LineEdit(filename As String, lineNum As Integer) As String
123On Error GoTo errlabel
124If lineNum < 1 Then
125LineEdit = ""
126Exit Function
127End If
128Dim fso As New FileSystemObject
129If Not fso.FileExists(filename) Then
130LineEdit = ""
131Exit Function
132Else
133Dim f As TextStream
134Dim tempcnt As String
135Dim temparray
136Set f = fso.OpenTextFile(filename, 1)
137If Not f.AtEndOfStream Then tempcnt = f.ReadAll
138f.Close
139Set f = Nothing
140temparray = Split(tempcnt, Chr(13) & Chr(10))
141If lineNum > UBound(temparray) + 1 Then
142LineEdit = ""
143Exit Function
144Else
145LineEdit = temparray(lineNum - 1)
146End If
147End If
148Exit Function
149errlabel:
150LineEdit = ""
151End Function
152
153'3.读取文件中最后一行内容的函数
154'其实和读取某一行的函数类似，主要即是 数组的上界ubound值 就是最末的值 ，故为最后一行。函数的引用也很简单。
155
156Function LastLine(filename As String) As String
157On Error GoTo errlabel
158Dim fso As New FileSystemObject
159If Not fso.FileExists(filename) Then
160LastLine = ""
161Exit Function
162End If
163Dim f As TextStream
164Dim tempcnt As String
165Dim temparray
166Set f = fso.OpenTextFile(filename, 1)
167If Not f.AtEndOfStream Then
168tempcnt = f.ReadAll
169f.Close
170Set f = Nothing
171temparray = Split(tempcnt, Chr(13) & Chr(10))
172LastLine = temparray(UBound(temparray))
173End If
174Exit Function
175errlabel:
176LastLine = ""
177End Function
178
179'在ASP中自动创建多级文件夹的函数
180'FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,
181'所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.
182'--------------------------------
183' 自动创建指定的多级文件夹
184' strPath为绝对路径
185
186Function AutoCreateFolder(strPath) As Boolean
187On Error Resume Next
188Dim astrPath
189Dim ulngPath As Integer
190Dim i As Integer
191Dim strTmpPath As String
192
193If InStr(strPath, "\") <= 0 Or InStr(strPath, ":") <= 0 Then
194AutoCreateFolder = False
195Exit Function
196End If
197Dim objFSO As New FileSystemObject
198If objFSO.FolderExists(strPath) Then
199AutoCreateFolder = True
200Exit Function
201End If
202astrPath = Split(strPath, "\")
203ulngPath = UBound(astrPath)
204strTmpPath = ""
205For i = 0 To ulngPath
206strTmpPath = strTmpPath & astrPath(i) & "\"
207If Not objFSO.FolderExists(strTmpPath) Then
208' 创建
209objFSO.CreateFolder (strTmpPath)
210End If
211Next
212Set objFSO = Nothing
213If Err = 0 Then
214AutoCreateFolder = True
215Else
216AutoCreateFolder = False
217End If
218End Function
219
FSO操作1
'此函数从字符串中分离出路径2
Public Function ParsePath(sPathIn As String) As String3
Dim i As Integer4
For i = Len(sPathIn) To 1 Step -15
If InStr(":\", Mid$(sPathIn, i, 1)) Then Exit For6
Next7
ParsePath = Left$(sPathIn, i)8
End Function9
10
'此函数从字符串中分离出文件名11
Public Function ParseFileName(sFileIn As String) As String12
Dim i As Integer13
For i = Len(sFileIn) To 1 Step -114
If InStr("\", Mid$(sFileIn, i, 1)) Then Exit For15
Next16
ParseFileName = Mid$(sFileIn, i + 1, Len(sFileIn) - i)17
End Function18
19
Public Sub openExcel(path As String) 'path表示需要打开的Excel文件的路径20
'调用EXCEL打开产生的EXCEL表格,不需要预先知道程序安装,存放路径21
'Shell "E:\Program Files\Office 2003\Office11\EXCEL.EXE D:\Excel.xls", vbMaximizedFocus22
On Error GoTo errlabel23
Dim MyXlsApp As Object '24
Set MyXlsApp = CreateObject("Excel.Application") 'App.Path & "\EXCEL.xls"25
MyXlsApp.Workbooks.Open filename:=path '', Password:="123", ReadOnly:=False,如果文件设置了密码,需要提供密码,可以设置文件打开方式,只读方式26
MyXlsApp.Visible = True '设置Excel成为可见27
Set MyXlsApp = Nothing '释放对象28
Exit Sub29
errlabel:30
MsgBox "无法打开指定的Excel文件,有可能你的电脑中没有" & _31
"安装Excel或者指定的文件不存在!", vbCritical, "打开Excel文件" + ParseFileName(path) + "出错提示"32
End Sub33
34
Public Sub openWord(path As String) 'path表示需要打开的Word文件的路径35
'调用Word打开产生的Word文档，不需要预先知道程序安装,存放路径36
On Error GoTo errlabel37
Dim word As New word.Application38
word.Documents.Open filename:=path39
word.Visible = True '设置word成为可见40
Set word = Nothing '释放对象41
Exit Sub42
errlabel:43
MsgBox "无法打开指定的Word文档,有可能你的电脑中没有" & _44
"安装Word或者指定的文件不存在!", vbCritical, "打开Word文件" + ParseFileName(path) + "出错提示"45
End Sub46
47
Public Sub CreateAccess(filename As String)48
On Error Resume Next49
Dim obj As New FileSystemObject50
If Not obj.FileExists(filename) Then51
Dim Access As New Access.Application52
Access.NewCurrentDatabase (filename)53
Access.DoCmd.RunSQL ("create table table1 (empty text(20));")54
Access.DoCmd.Save acDefault55
Access.Quit acQuitSaveAll56
End If57
End Sub58
59
'===========================================================================================60
'函数checkDir()用来检查当前程序所在目录下,是否存在下列文件夹Backup,Images,Docs,Report,Upload61
'Backup--------------存放数据库备份文件62
'Images--------------存放干部的照片63
'Docs----------------存放干部的审判材料64
'Report--------------存放生成的各种报表文件65
'Upload--------------存放导出的上报文件66
'===========================================================================================67
Public Sub checkDir(dir() As String)68
On Error Resume Next69
Dim obj As New FileSystemObject70
Dim i As Integer71
For i = LBound(dir) To UBound(dir) Step 172
If Not obj.FolderExists(App.path + dir(i)) Then73
obj.CreateFolder App.path + dir(i)74
End If75
Next i76
End Sub77
78
'判断字符串中是否含有空格,单引号,双引号等特殊字符79
Public Function checkInput(iStr As String) As Boolean80
If InStr(iStr, " ") > 0 Or InStr(iStr, "'") > 0 Or InStr(iStr, """") > 0 Then81
checkInput = False82
Exit Function83
Else84
checkInput = True85
Exit Function86
End If87
End Function88
89
'FSO的几个应用函数90
91
'1.读取文件中所有字符的函数92
'其实就是通过ReadLine（读取行），通过 While Not cnrs.AtEndOfStream 的条件进行循环读取行，93
'来达到读取文件中所有字符。当然也可以使用ReadAll代替多个ReadLine，但主要缺点是将格式进行换行等问题需要再次解决。94
'引用函数 call FSOFileRead("xxx文件") 即可95
96
Function FileReadAll(filename As String) As String97
On Error GoTo errlabel98
Dim fso As New FileSystemObject99
If Not fso.FileExists(filename) Then100
FileReadAll = ""101
Exit Function102
Else103
Dim cnrs As TextStream104
Dim rsline As String105
rsline = ""106
Set cnrs = fso.OpenTextFile(filename, 1)107
While Not cnrs.AtEndOfStream108
rsline = rsline & cnrs.ReadLine109
Wend110
FileReadAll = rsline111
Exit Function112
End If113
errlabel:114
FileReadAll = ""115
End Function116
117
'2读取文件中某一行中所有字符的函数118
'这次即使用了readall方法，通过split函数将读取的内容以换行为条件，进行数组的定义，119
'提取 lineNum-1（数组从0记数） 所对应的数组值即为 读取的该行值 ，也就是该行中所有的字符了。120
'函数的调用 call FSOlinedit("xxx文件",35) 表示显示xxx文件的第35行内容121
122
Function LineEdit(filename As String, lineNum As Integer) As String123
On Error GoTo errlabel124
If lineNum < 1 Then125
LineEdit = ""126
Exit Function127
End If128
Dim fso As New FileSystemObject129
If Not fso.FileExists(filename) Then130
LineEdit = ""131
Exit Function132
Else133
Dim f As TextStream134
Dim tempcnt As String135
Dim temparray136
Set f = fso.OpenTextFile(filename, 1)137
If Not f.AtEndOfStream Then tempcnt = f.ReadAll138
f.Close139
Set f = Nothing140
temparray = Split(tempcnt, Chr(13) & Chr(10))141
If lineNum > UBound(temparray) + 1 Then142
LineEdit = ""143
Exit Function144
Else145
LineEdit = temparray(lineNum - 1)146
End If147
End If148
Exit Function149
errlabel:150
LineEdit = ""151
End Function152
153
'3.读取文件中最后一行内容的函数154
'其实和读取某一行的函数类似，主要即是 数组的上界ubound值 就是最末的值 ，故为最后一行。函数的引用也很简单。155
156
Function LastLine(filename As String) As String157
On Error GoTo errlabel158
Dim fso As New FileSystemObject159
If Not fso.FileExists(filename) Then160
LastLine = ""161
Exit Function162
End If163
Dim f As TextStream164
Dim tempcnt As String165
Dim temparray166
Set f = fso.OpenTextFile(filename, 1)167
If Not f.AtEndOfStream Then168
tempcnt = f.ReadAll169
f.Close170
Set f = Nothing171
temparray = Split(tempcnt, Chr(13) & Chr(10))172
LastLine = temparray(UBound(temparray))173
End If174
Exit Function175
errlabel:176
LastLine = ""177
End Function178
179
'在ASP中自动创建多级文件夹的函数180
'FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,181
'所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.182
'--------------------------------183
' 自动创建指定的多级文件夹184
' strPath为绝对路径185
186
Function AutoCreateFolder(strPath) As Boolean187
On Error Resume Next188
Dim astrPath189
Dim ulngPath As Integer190
Dim i As Integer191
Dim strTmpPath As String192
193
If InStr(strPath, "\") <= 0 Or InStr(strPath, ":") <= 0 Then194
AutoCreateFolder = False195
Exit Function196
End If197
Dim objFSO As New FileSystemObject198
If objFSO.FolderExists(strPath) Then199
AutoCreateFolder = True200
Exit Function201
End If202
astrPath = Split(strPath, "\")203
ulngPath = UBound(astrPath)204
strTmpPath = ""205
For i = 0 To ulngPath206
strTmpPath = strTmpPath & astrPath(i) & "\"207
If Not objFSO.FolderExists(strTmpPath) Then208
' 创建209
objFSO.CreateFolder (strTmpPath)210
End If211
Next212
Set objFSO = Nothing213
If Err = 0 Then214
AutoCreateFolder = True215
Else216
AutoCreateFolder = False217
End If218
End Function219
作者：peterzb（个人开发历程知识库 -
博客园）
出处：http://peterzb.cnblogs.com/
文章版权归本人所有，欢迎转载，但未经作者同意必须保留此段声明，且在文章页面明显位置给出原文连接，否则保留追究法律责任的权利。
