好几年前写的, 现从CSDN博客中转移过来.
![]()
![]()
FSO操作
1![]()
'此函数从字符串中分离出路径
2![]()
Public Function ParsePath(sPathIn As String) As String
3![]()
Dim i As Integer
4![]()
For i = Len(sPathIn) To 1 Step -1
5![]()
If InStr(":\", Mid$(sPathIn, i, 1)) Then Exit For
6![]()
Next
7![]()
ParsePath = Left$(sPathIn, i)
8![]()
End Function
9![]()
10![]()
'此函数从字符串中分离出文件名
11![]()
Public Function ParseFileName(sFileIn As String) As String
12![]()
Dim i As Integer
13![]()
For i = Len(sFileIn) To 1 Step -1
14![]()
If InStr("\", Mid$(sFileIn, i, 1)) Then Exit For
15![]()
Next
16![]()
ParseFileName = Mid$(sFileIn, i + 1, Len(sFileIn) - i)
17![]()
End Function
18![]()
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", 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
29![]()
errlabel:
30![]()
MsgBox "无法打开指定的Excel文件,有可能你的电脑中没有" & _
31![]()
"安装Excel或者指定的文件不存在!", vbCritical, "打开Excel文件" + ParseFileName(path) + "出错提示"
32![]()
End Sub
33![]()
34![]()
Public 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
42![]()
errlabel:
43![]()
MsgBox "无法打开指定的Word文档,有可能你的电脑中没有" & _
44![]()
"安装Word或者指定的文件不存在!", vbCritical, "打开Word文件" + ParseFileName(path) + "出错提示"
45![]()
End Sub
46![]()
47![]()
Public Sub CreateAccess(filename As String)
48![]()
On Error Resume Next
49![]()
Dim obj As New FileSystemObject
50![]()
If Not obj.FileExists(filename) Then
51![]()
Dim Access As New Access.Application
52![]()
Access.NewCurrentDatabase (filename)
53![]()
Access.DoCmd.RunSQL ("create table table1 (empty text(20));")
54![]()
Access.DoCmd.Save acDefault
55![]()
Access.Quit acQuitSaveAll
56![]()
End If
57![]()
End Sub
58![]()
59![]()
'===========================================================================================
60![]()
'函数checkDir()用来检查当前程序所在目录下,是否存在下列文件夹Backup,Images,Docs,Report,Upload
61![]()
'Backup--------------存放数据库备份文件
62![]()
'Images--------------存放干部的照片
63![]()
'Docs----------------存放干部的审判材料
64![]()
'Report--------------存放生成的各种报表文件
65![]()
'Upload--------------存放导出的上报文件
66![]()
'===========================================================================================
67![]()
Public Sub checkDir(dir() As String)
68![]()
On Error Resume Next
69![]()
Dim obj As New FileSystemObject
70![]()
Dim i As Integer
71![]()
For i = LBound(dir) To UBound(dir) Step 1
72![]()
If Not obj.FolderExists(App.path + dir(i)) Then
73![]()
obj.CreateFolder App.path + dir(i)
74![]()
End If
75![]()
Next i
76![]()
End Sub
77![]()
78![]()
'判断字符串中是否含有空格,单引号,双引号等特殊字符
79![]()
Public Function checkInput(iStr As String) As Boolean
80![]()
If InStr(iStr, " ") > 0 Or InStr(iStr, "'") > 0 Or InStr(iStr, """") > 0 Then
81![]()
checkInput = False
82![]()
Exit Function
83![]()
Else
84![]()
checkInput = True
85![]()
Exit Function
86![]()
End If
87![]()
End Function
88![]()
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 String
97![]()
On Error GoTo errlabel
98![]()
Dim fso As New FileSystemObject
99![]()
If Not fso.FileExists(filename) Then
100![]()
FileReadAll = ""
101![]()
Exit Function
102![]()
Else
103![]()
Dim cnrs As TextStream
104![]()
Dim rsline As String
105![]()
rsline = ""
106![]()
Set cnrs = fso.OpenTextFile(filename, 1)
107![]()
While Not cnrs.AtEndOfStream
108![]()
rsline = rsline & cnrs.ReadLine
109![]()
Wend
110![]()
FileReadAll = rsline
111![]()
Exit Function
112![]()
End If
113![]()
errlabel:
114![]()
FileReadAll = ""
115![]()
End Function
116![]()
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 String
123![]()
On Error GoTo errlabel
124![]()
If lineNum < 1 Then
125![]()
LineEdit = ""
126![]()
Exit Function
127![]()
End If
128![]()
Dim fso As New FileSystemObject
129![]()
If Not fso.FileExists(filename) Then
130![]()
LineEdit = ""
131![]()
Exit Function
132![]()
Else
133![]()
Dim f As TextStream
134![]()
Dim tempcnt As String
135![]()
Dim temparray
136![]()
Set f = fso.OpenTextFile(filename, 1)
137![]()
If Not f.AtEndOfStream Then tempcnt = f.ReadAll
138![]()
f.Close
139![]()
Set f = Nothing
140![]()
temparray = Split(tempcnt, Chr(13) & Chr(10))
141![]()
If lineNum > UBound(temparray) + 1 Then
142![]()
LineEdit = ""
143![]()
Exit Function
144![]()
Else
145![]()
LineEdit = temparray(lineNum - 1)
146![]()
End If
147![]()
End If
148![]()
Exit Function
149![]()
errlabel:
150![]()
LineEdit = ""
151![]()
End Function
152![]()
153![]()
'3.读取文件中最后一行内容的函数
154![]()
'其实和读取某一行的函数类似，主要即是 数组的上界ubound值 就是最末的值 ，故为最后一行。函数的引用也很简单。
155![]()
156![]()
Function LastLine(filename As String) As String
157![]()
On Error GoTo errlabel
158![]()
Dim fso As New FileSystemObject
159![]()
If Not fso.FileExists(filename) Then
160![]()
LastLine = ""
161![]()
Exit Function
162![]()
End If
163![]()
Dim f As TextStream
164![]()
Dim tempcnt As String
165![]()
Dim temparray
166![]()
Set f = fso.OpenTextFile(filename, 1)
167![]()
If Not f.AtEndOfStream Then
168![]()
tempcnt = f.ReadAll
169![]()
f.Close
170![]()
Set f = Nothing
171![]()
temparray = Split(tempcnt, Chr(13) & Chr(10))
172![]()
LastLine = temparray(UBound(temparray))
173![]()
End If
174![]()
Exit Function
175![]()
errlabel:
176![]()
LastLine = ""
177![]()
End Function
178![]()
179![]()
'在ASP中自动创建多级文件夹的函数
180![]()
'FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,
181![]()
'所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.
182![]()
'--------------------------------
183![]()
' 自动创建指定的多级文件夹
184![]()
' strPath为绝对路径
185![]()
186![]()
Function AutoCreateFolder(strPath) As Boolean
187![]()
On Error Resume Next
188![]()
Dim astrPath
189![]()
Dim ulngPath As Integer
190![]()
Dim i As Integer
191![]()
Dim strTmpPath As String
192![]()
193![]()
If InStr(strPath, "\") <= 0 Or InStr(strPath, ":") <= 0 Then
194![]()
AutoCreateFolder = False
195![]()
Exit Function
196![]()
End If
197![]()
Dim objFSO As New FileSystemObject
198![]()
If objFSO.FolderExists(strPath) Then
199![]()
AutoCreateFolder = True
200![]()
Exit Function
201![]()
End If
202![]()
astrPath = Split(strPath, "\")
203![]()
ulngPath = UBound(astrPath)
204![]()
strTmpPath = ""
205![]()
For i = 0 To ulngPath
206![]()
strTmpPath = strTmpPath & astrPath(i) & "\"
207![]()
If Not objFSO.FolderExists(strTmpPath) Then
208![]()
' 创建
209![]()
objFSO.CreateFolder (strTmpPath)
210![]()
End If
211![]()
Next
212![]()
Set objFSO = Nothing
213![]()
If Err = 0 Then
214![]()
AutoCreateFolder = True
215![]()
Else
216![]()
AutoCreateFolder = False
217![]()
End If
218![]()
End 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/
文章版权归本人所有，欢迎转载，但未经作者同意必须保留此段声明，且在文章页面明显位置给出原文连接，否则保留追究法律责任的权利。
浙公网安备 33010602011771号