1
'
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 String
9 On Error GoTo errlabel
10 Dim fso As New FileSystemObject
11 If Not fso.FileExists(filename) Then
12 FileReadAll = ""
13 Exit Function
14 Else
15 Dim cnrs As TextStream
16 Dim rsline As String
17 rsline = ""
18 Set cnrs = fso.OpenTextFile(filename, 1 )
19 While Not cnrs.AtEndOfStream
20 rsline = rsline & cnrs.ReadLine
21 Wend
22 FileReadAll = rsline
23 Exit Function
24 End If
25 errlabel:
26 FileReadAll = ""
27 End Function
28
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 String
35 On Error GoTo errlabel
36 If lineNum < 1 Then
37 LineEdit = ""
38 Exit Function
39 End If
40 Dim fso As New FileSystemObject
41 If Not fso.FileExists(filename) Then
42 LineEdit = ""
43 Exit Function
44 Else
45 Dim f As TextStream
46 Dim tempcnt As String
47 Dim temparray
48 Set f = fso.OpenTextFile(filename, 1 )
49 If Not f.AtEndOfStream Then tempcnt = f.ReadAll
50 f.Close
51 Set f = Nothing
52 temparray = Split (tempcnt, Chr ( 13 ) & Chr ( 10 ))
53 If lineNum > UBound (temparray) + 1 Then
54 LineEdit = ""
55 Exit Function
56 Else
57 LineEdit = temparray(lineNum - 1 )
58 End If
59 End If
60 Exit Function
61 errlabel:
62 LineEdit = ""
63 End Function
64
65 ' 3.读取文件中最后一行内容的函数
66 ' 其实和读取某一行的函数类似,主要即是 数组的上界ubound值 就是最末的值 ,故为最后一行。函数的引用也很简单。
67
68 Function LastLine(filename As String ) As String
69 On Error GoTo errlabel
70 Dim fso As New FileSystemObject
71 If Not fso.FileExists(filename) Then
72 LastLine = ""
73 Exit Function
74 End If
75 Dim f As TextStream
76 Dim tempcnt As String
77 Dim temparray
78 Set f = fso.OpenTextFile(filename, 1 )
79 If Not f.AtEndOfStream Then
80 tempcnt = f.ReadAll
81 f.Close
82 Set f = Nothing
83 temparray = Split (tempcnt, Chr ( 13 ) & Chr ( 10 ))
84 LastLine = temparray( UBound (temparray))
85 End If
86 Exit Function
87 errlabel:
88 LastLine = ""
89 End Function
90
91 ' 在ASP中自动创建多级文件夹的函数
92 ' FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,
93 ' 所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.
94 ' --------------------------------
95 ' 自动创建指定的多级文件夹
96 ' strPath为绝对路径
97
98 Function AutoCreateFolder(strPath) As Boolean
99 On Error Resume Next
100 Dim astrPath
101 Dim ulngPath As Integer
102 Dim i As Integer
103 Dim strTmpPath As String
104
105 If InStr (strPath, " \ " ) <= 0 Or InStr (strPath, " : " ) <= 0 Then
106 AutoCreateFolder = False
107 Exit Function
108 End If
109 Dim objFSO As New FileSystemObject
110 If objFSO.FolderExists(strPath) Then
111 AutoCreateFolder = True
112 Exit Function
113 End If
114 astrPath = Split (strPath, " \ " )
115 ulngPath = UBound (astrPath)
116 strTmpPath = ""
117 For i = 0 To ulngPath
118 strTmpPath = strTmpPath & astrPath(i) & " \ "
119 If Not objFSO.FolderExists(strTmpPath) Then
120 ' 创建
121 objFSO.CreateFolder (strTmpPath)
122 End If
123 Next
124 Set objFSO = Nothing
125 If Err = 0 Then
126 AutoCreateFolder = True
127 Else
128 AutoCreateFolder = False
129 End If
130 End Function
131
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 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
170 End Sub
171
172 ' 延时过程,Delay 单位约为 1 秒
173 Private Sub Waitfor(Delay As Single )
174 Dim StartTime As Single
175 StartTime = Timer
176 Do Until ( Timer - StartTime) > Delay
177 Loop
178 End Sub
179
2
3 ' 1.读取文件中所有字符的函数
4 ' 其实就是通过ReadLine(读取行),通过 While Not cnrs.AtEndOfStream 的条件进行循环读取行,
5 ' 来达到读取文件中所有字符。当然也可以使用ReadAll代替多个ReadLine,但主要缺点是将格式进行换行等问题需要再次解决。
6 ' 引用函数 call FSOFileRead("xxx文件") 即可
7
8 Function FileReadAll(filename As String ) As String
9 On Error GoTo errlabel
10 Dim fso As New FileSystemObject
11 If Not fso.FileExists(filename) Then
12 FileReadAll = ""
13 Exit Function
14 Else
15 Dim cnrs As TextStream
16 Dim rsline As String
17 rsline = ""
18 Set cnrs = fso.OpenTextFile(filename, 1 )
19 While Not cnrs.AtEndOfStream
20 rsline = rsline & cnrs.ReadLine
21 Wend
22 FileReadAll = rsline
23 Exit Function
24 End If
25 errlabel:
26 FileReadAll = ""
27 End Function
28
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 String
35 On Error GoTo errlabel
36 If lineNum < 1 Then
37 LineEdit = ""
38 Exit Function
39 End If
40 Dim fso As New FileSystemObject
41 If Not fso.FileExists(filename) Then
42 LineEdit = ""
43 Exit Function
44 Else
45 Dim f As TextStream
46 Dim tempcnt As String
47 Dim temparray
48 Set f = fso.OpenTextFile(filename, 1 )
49 If Not f.AtEndOfStream Then tempcnt = f.ReadAll
50 f.Close
51 Set f = Nothing
52 temparray = Split (tempcnt, Chr ( 13 ) & Chr ( 10 ))
53 If lineNum > UBound (temparray) + 1 Then
54 LineEdit = ""
55 Exit Function
56 Else
57 LineEdit = temparray(lineNum - 1 )
58 End If
59 End If
60 Exit Function
61 errlabel:
62 LineEdit = ""
63 End Function
64
65 ' 3.读取文件中最后一行内容的函数
66 ' 其实和读取某一行的函数类似,主要即是 数组的上界ubound值 就是最末的值 ,故为最后一行。函数的引用也很简单。
67
68 Function LastLine(filename As String ) As String
69 On Error GoTo errlabel
70 Dim fso As New FileSystemObject
71 If Not fso.FileExists(filename) Then
72 LastLine = ""
73 Exit Function
74 End If
75 Dim f As TextStream
76 Dim tempcnt As String
77 Dim temparray
78 Set f = fso.OpenTextFile(filename, 1 )
79 If Not f.AtEndOfStream Then
80 tempcnt = f.ReadAll
81 f.Close
82 Set f = Nothing
83 temparray = Split (tempcnt, Chr ( 13 ) & Chr ( 10 ))
84 LastLine = temparray( UBound (temparray))
85 End If
86 Exit Function
87 errlabel:
88 LastLine = ""
89 End Function
90
91 ' 在ASP中自动创建多级文件夹的函数
92 ' FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,
93 ' 所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.
94 ' --------------------------------
95 ' 自动创建指定的多级文件夹
96 ' strPath为绝对路径
97
98 Function AutoCreateFolder(strPath) As Boolean
99 On Error Resume Next
100 Dim astrPath
101 Dim ulngPath As Integer
102 Dim i As Integer
103 Dim strTmpPath As String
104
105 If InStr (strPath, " \ " ) <= 0 Or InStr (strPath, " : " ) <= 0 Then
106 AutoCreateFolder = False
107 Exit Function
108 End If
109 Dim objFSO As New FileSystemObject
110 If objFSO.FolderExists(strPath) Then
111 AutoCreateFolder = True
112 Exit Function
113 End If
114 astrPath = Split (strPath, " \ " )
115 ulngPath = UBound (astrPath)
116 strTmpPath = ""
117 For i = 0 To ulngPath
118 strTmpPath = strTmpPath & astrPath(i) & " \ "
119 If Not objFSO.FolderExists(strTmpPath) Then
120 ' 创建
121 objFSO.CreateFolder (strTmpPath)
122 End If
123 Next
124 Set objFSO = Nothing
125 If Err = 0 Then
126 AutoCreateFolder = True
127 Else
128 AutoCreateFolder = False
129 End If
130 End Function
131
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 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
170 End Sub
171
172 ' 延时过程,Delay 单位约为 1 秒
173 Private Sub Waitfor(Delay As Single )
174 Dim StartTime As Single
175 StartTime = Timer
176 Do Until ( Timer - StartTime) > Delay
177 Loop
178 End Sub
179
本文转自peterzb博客园博客,原文链接:http://www.cnblogs.com/peterzb/archive/2006/04/23/382793.html,如需转载请自行联系原作者。