FSO的几个应用函数[VB]

  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

本文转自peterzb博客园博客，原文链接：http://www.cnblogs.com/peterzb/archive/2006/04/23/382793.html，如需转载请自行联系原作者。