一些常用的vb函数/过程[操作FSO方面]

    好几年前写的, 现从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