1
'FSO的几个应用函数
2
3'1.读取文件中所有字符的函数
4'其实就是通过ReadLine（读取行），通过 While Not cnrs.AtEndOfStream 的条件进行循环读取行，
5'来达到读取文件中所有字符。当然也可以使用ReadAll代替多个ReadLine，但主要缺点是将格式进行换行等问题需要再次解决。
6'引用函数 call FSOFileRead("xxx文件") 即可
7
8Function FileReadAll(filename As String) As String
9On Error GoTo errlabel
10Dim fso As New FileSystemObject
11If Not fso.FileExists(filename) Then
12FileReadAll = ""
13Exit Function
14Else
15Dim cnrs As TextStream
16Dim rsline As String
17rsline = ""
18Set cnrs = fso.OpenTextFile(filename, 1)
19While Not cnrs.AtEndOfStream
20rsline = rsline & cnrs.ReadLine
21Wend
22FileReadAll = rsline
23Exit Function
24End If
25errlabel:
26FileReadAll = ""
27End Function
28
29'2读取文件中某一行中所有字符的函数
30'这次即使用了readall方法，通过split函数将读取的内容以换行为条件，进行数组的定义，
31'提取 lineNum-1（数组从0记数） 所对应的数组值即为 读取的该行值 ，也就是该行中所有的字符了。
32'函数的调用 call FSOlinedit("xxx文件",35) 表示显示xxx文件的第35行内容
33
34Function LineEdit(filename As String, lineNum As Integer) As String
35On Error GoTo errlabel
36If lineNum < 1 Then
37LineEdit = ""
38Exit Function
39End If
40Dim fso As New FileSystemObject
41If Not fso.FileExists(filename) Then
42LineEdit = ""
43Exit Function
44Else
45Dim f As TextStream
46Dim tempcnt As String
47Dim temparray
48Set f = fso.OpenTextFile(filename, 1)
49If Not f.AtEndOfStream Then tempcnt = f.ReadAll
50f.Close
51Set f = Nothing
52temparray = Split(tempcnt, Chr(13) & Chr(10))
53If lineNum > UBound(temparray) + 1 Then
54LineEdit = ""
55Exit Function
56Else
57LineEdit = temparray(lineNum - 1)
58End If
59End If
60Exit Function
61errlabel:
62LineEdit = ""
63End Function
64
65'3.读取文件中最后一行内容的函数
66'其实和读取某一行的函数类似，主要即是 数组的上界ubound值 就是最末的值 ，故为最后一行。函数的引用也很简单。
67
68Function LastLine(filename As String) As String
69On Error GoTo errlabel
70Dim fso As New FileSystemObject
71If Not fso.FileExists(filename) Then
72LastLine = ""
73Exit Function
74End If
75Dim f As TextStream
76Dim tempcnt As String
77Dim temparray
78Set f = fso.OpenTextFile(filename, 1)
79If Not f.AtEndOfStream Then
80tempcnt = f.ReadAll
81f.Close
82Set f = Nothing
83temparray = Split(tempcnt, Chr(13) & Chr(10))
84LastLine = temparray(UBound(temparray))
85End If
86Exit Function
87errlabel:
88LastLine = ""
89End Function
90
91'在ASP中自动创建多级文件夹的函数
92'FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,
93'所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.
94'--------------------------------
95' 自动创建指定的多级文件夹
96' strPath为绝对路径
97
98Function AutoCreateFolder(strPath) As Boolean
99On Error Resume Next
100Dim astrPath
101Dim ulngPath As Integer
102Dim i As Integer
103Dim strTmpPath As String
104
105If InStr(strPath, "\") <= 0 Or InStr(strPath, ":") <= 0 Then
106AutoCreateFolder = False
107Exit Function
108End If
109Dim objFSO As New FileSystemObject
110If objFSO.FolderExists(strPath) Then
111AutoCreateFolder = True
112Exit Function
113End If
114astrPath = Split(strPath, "\")
115ulngPath = UBound(astrPath)
116strTmpPath = ""
117For i = 0 To ulngPath
118strTmpPath = strTmpPath & astrPath(i) & "\"
119If Not objFSO.FolderExists(strTmpPath) Then
120' 创建
121objFSO.CreateFolder (strTmpPath)
122End If
123Next
124Set objFSO = Nothing
125If Err = 0 Then
126AutoCreateFolder = True
127Else
128AutoCreateFolder = False
129End If
130End Function
131
132 '一个文件备份通用过程:
133 'Filename = 文件名，Drive = 驱动器，Folder = 文件夹(一层)
134Public Sub BackupFile(filename As String, Drive As String, folder As String)
135 Dim fso As New FileSystemObject '创建 FSO 对象实例
136 Dim Dest_path As String, Counter As Long
137 Counter = 0
138 Do While Counter < 6 '如果驱动器没准备好，继续检测。共检测 6 秒
139 Counter = Counter + 1
140 Call Waitfor(1) '间隔 1 秒
141 If fso.Drives(Drive).IsReady = True Then
142 Exit Do
143 End If
144 Loop
145 If fso.Drives(Drive).IsReady = False Then '6 秒后目标盘仍未准备就绪，退出
146 MsgBox " 目标驱动器 " & Drive & " 没有准备好！ ", vbCritical
147 Exit Sub
148 End If
149 If fso.GetDrive(Drive).FreeSpace < fso.GetFile(filename).Size Then
150 MsgBox "目标驱动器空间太小！", vbCritical '目标驱动器空间不够，退出
151 Exit Sub
152 End If
153 If Right(Drive, 1) <> ":" Then
154 Drive = Drive & ":"
155 End If
156 If Left(folder, 1) <> "\" Then
157 folder = "\" & folder
158 End If
159 If Right(folder, 1) <> "\" Then
160 folder = folder & "\"
161 End If
162 Dest_path = Drive & folder
163 If Not fso.FolderExists(Dest_path) Then '如果目标文件夹不存在，创建之
164 fso.CreateFolder Dest_path
165 End If
166 fso.CopyFile filename, Dest_path & fso.GetFileName(filename), True
167 '拷贝，直接覆盖同名文件
168 MsgBox " 文件备份完毕。", vbOKOnly
169 Set fso = Nothing
170End Sub
171
172'延时过程，Delay 单位约为 1 秒
173Private Sub Waitfor(Delay As Single)
174 Dim StartTime As Single
175 StartTime = Timer
176 Do Until (Timer - StartTime) > Delay
177 Loop
178End Sub
179
'FSO的几个应用函数2
3
'1.读取文件中所有字符的函数4
'其实就是通过ReadLine（读取行），通过 While Not cnrs.AtEndOfStream 的条件进行循环读取行，5
'来达到读取文件中所有字符。当然也可以使用ReadAll代替多个ReadLine，但主要缺点是将格式进行换行等问题需要再次解决。6
'引用函数 call FSOFileRead("xxx文件") 即可7
8
Function FileReadAll(filename As String) As String9
On Error GoTo errlabel10
Dim fso As New FileSystemObject11
If Not fso.FileExists(filename) Then12
FileReadAll = ""13
Exit Function14
Else15
Dim cnrs As TextStream16
Dim rsline As String17
rsline = ""18
Set cnrs = fso.OpenTextFile(filename, 1)19
While Not cnrs.AtEndOfStream20
rsline = rsline & cnrs.ReadLine21
Wend22
FileReadAll = rsline23
Exit Function24
End If25
errlabel:26
FileReadAll = ""27
End Function28
29
'2读取文件中某一行中所有字符的函数30
'这次即使用了readall方法，通过split函数将读取的内容以换行为条件，进行数组的定义，31
'提取 lineNum-1（数组从0记数） 所对应的数组值即为 读取的该行值 ，也就是该行中所有的字符了。32
'函数的调用 call FSOlinedit("xxx文件",35) 表示显示xxx文件的第35行内容33
34
Function LineEdit(filename As String, lineNum As Integer) As String35
On Error GoTo errlabel36
If lineNum < 1 Then37
LineEdit = ""38
Exit Function39
End If40
Dim fso As New FileSystemObject41
If Not fso.FileExists(filename) Then42
LineEdit = ""43
Exit Function44
Else45
Dim f As TextStream46
Dim tempcnt As String47
Dim temparray48
Set f = fso.OpenTextFile(filename, 1)49
If Not f.AtEndOfStream Then tempcnt = f.ReadAll50
f.Close51
Set f = Nothing52
temparray = Split(tempcnt, Chr(13) & Chr(10))53
If lineNum > UBound(temparray) + 1 Then54
LineEdit = ""55
Exit Function56
Else57
LineEdit = temparray(lineNum - 1)58
End If59
End If60
Exit Function61
errlabel:62
LineEdit = ""63
End Function64
65
'3.读取文件中最后一行内容的函数66
'其实和读取某一行的函数类似，主要即是 数组的上界ubound值 就是最末的值 ，故为最后一行。函数的引用也很简单。67
68
Function LastLine(filename As String) As String69
On Error GoTo errlabel70
Dim fso As New FileSystemObject71
If Not fso.FileExists(filename) Then72
LastLine = ""73
Exit Function74
End If75
Dim f As TextStream76
Dim tempcnt As String77
Dim temparray78
Set f = fso.OpenTextFile(filename, 1)79
If Not f.AtEndOfStream Then80
tempcnt = f.ReadAll81
f.Close82
Set f = Nothing83
temparray = Split(tempcnt, Chr(13) & Chr(10))84
LastLine = temparray(UBound(temparray))85
End If86
Exit Function87
errlabel:88
LastLine = ""89
End Function90
91
'在ASP中自动创建多级文件夹的函数92
'FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,93
'所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.94
'--------------------------------95
' 自动创建指定的多级文件夹96
' strPath为绝对路径97
98
Function AutoCreateFolder(strPath) As Boolean99
On Error Resume Next100
Dim astrPath101
Dim ulngPath As Integer102
Dim i As Integer103
Dim strTmpPath As String104
105
If InStr(strPath, "\") <= 0 Or InStr(strPath, ":") <= 0 Then106
AutoCreateFolder = False107
Exit Function108
End If109
Dim objFSO As New FileSystemObject110
If objFSO.FolderExists(strPath) Then111
AutoCreateFolder = True112
Exit Function113
End If114
astrPath = Split(strPath, "\")115
ulngPath = UBound(astrPath)116
strTmpPath = ""117
For i = 0 To ulngPath118
strTmpPath = strTmpPath & astrPath(i) & "\"119
If Not objFSO.FolderExists(strTmpPath) Then120
' 创建121
objFSO.CreateFolder (strTmpPath)122
End If123
Next124
Set objFSO = Nothing125
If Err = 0 Then126
AutoCreateFolder = True127
Else128
AutoCreateFolder = False129
End If130
End Function131
132
'一个文件备份通用过程:133
'Filename = 文件名，Drive = 驱动器，Folder = 文件夹(一层)134
Public Sub BackupFile(filename As String, Drive As String, folder As String)135
Dim fso As New FileSystemObject '创建 FSO 对象实例136
Dim Dest_path As String, Counter As Long137
Counter = 0138
Do While Counter < 6 '如果驱动器没准备好，继续检测。共检测 6 秒139
Counter = Counter + 1140
Call Waitfor(1) '间隔 1 秒141
If fso.Drives(Drive).IsReady = True Then142
Exit Do143
End If144
Loop145
If fso.Drives(Drive).IsReady = False Then '6 秒后目标盘仍未准备就绪，退出146
MsgBox " 目标驱动器 " & Drive & " 没有准备好！ ", vbCritical147
Exit Sub148
End If149
If fso.GetDrive(Drive).FreeSpace < fso.GetFile(filename).Size Then150
MsgBox "目标驱动器空间太小！", vbCritical '目标驱动器空间不够，退出151
Exit Sub152
End If153
If Right(Drive, 1) <> ":" Then154
Drive = Drive & ":"155
End If156
If Left(folder, 1) <> "\" Then157
folder = "\" & folder158
End If159
If Right(folder, 1) <> "\" Then160
folder = folder & "\"161
End If162
Dest_path = Drive & folder163
If Not fso.FolderExists(Dest_path) Then '如果目标文件夹不存在，创建之164
fso.CreateFolder Dest_path165
End If166
fso.CopyFile filename, Dest_path & fso.GetFileName(filename), True167
'拷贝，直接覆盖同名文件168
MsgBox " 文件备份完毕。", vbOKOnly169
Set fso = Nothing170
End Sub171
172
'延时过程，Delay 单位约为 1 秒173
Private Sub Waitfor(Delay As Single)174
Dim StartTime As Single175
StartTime = Timer176
Do Until (Timer - StartTime) > Delay177
Loop178
End Sub179
本文转自peterzb博客园博客，原文链接：http://www.cnblogs.com/peterzb/archive/2006/04/23/382793.html，如需转载请自行联系原作者。
扫一扫
160
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
