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

好几年前写的, 现从CSDN博客中转移过来.
'此函数从字符串中分离出路径
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