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

'此函数从字符串中分离出路径
Public Function ParsePath(sPathIn As String) As String
Dim i As Integer
For i = Len(sPathIn) To 1 Step -1
   If InStr(":/", Mid$(sPathIn, i, 1)) Then Exit For
Next
ParsePath = Left$(sPathIn, i)
End Function

'此函数从字符串中分离出文件名
Public Function ParseFileName(sFileIn As String) As String
Dim i As Integer
For i = Len(sFileIn) To 1 Step -1
  If InStr("/", Mid$(sFileIn, i, 1)) Then Exit For
Next
ParseFileName = Mid$(sFileIn, i + 1, Len(sFileIn) - i)
End Function

Public Sub openExcel(path As String) 'path表示需要打开的Excel文件的路径
        '调用EXCEL打开产生的EXCEL表格,不需要预先知道程序安装,存放路径
        'Shell "E:/Program Files/Office 2003/Office11/EXCEL.EXE D:/Excel.xls", vbMaximizedFocus
        On Error GoTo errlabel
        Dim MyXlsApp As Object '
        Set MyXlsApp = CreateObject("Excel.Application") 'App.Path & "/EXCEL.xls"
        MyXlsApp.Workbooks.Open filename:=path '', Password:="123", ReadOnly:=False,如果文件设置了密码,需要提供密码,可以设置文件打开方式,只读方式
        MyXlsApp.Visible = True '设置Excel成为可见
        Set MyXlsApp = Nothing '释放对象
        Exit Sub
errlabel:
        MsgBox "无法打开指定的Excel文件,有可能你的电脑中没有" & _
        "安装Excel或者指定的文件不存在!", vbCritical, "打开Excel文件" + ParseFileName(path) + "出错提示"
End Sub

Public Sub openWord(path As String) 'path表示需要打开的Word文件的路径
        '调用Word打开产生的Word文档，不需要预先知道程序安装,存放路径
        On Error GoTo errlabel
        Dim word As New word.Application
        word.Documents.Open filename:=path
        word.Visible = True '设置word成为可见
        Set word = Nothing '释放对象
        Exit Sub
errlabel:
        MsgBox "无法打开指定的Word文档,有可能你的电脑中没有" & _
        "安装Word或者指定的文件不存在!", vbCritical, "打开Word文件" + ParseFileName(path) + "出错提示"
End Sub

Public Sub CreateAccess(filename As String)
On Error Resume Next
Dim obj As New FileSystemObject
If Not obj.FileExists(filename) Then
Dim Access As New Access.Application
Access.NewCurrentDatabase (filename)
Access.DoCmd.RunSQL ("create table table1 (empty text(20));")
Access.DoCmd.Save acDefault
Access.Quit acQuitSaveAll
End If
End Sub

'===========================================================================================
'函数checkDir()用来检查当前程序所在目录下,是否存在下列文件夹Backup,Images,Docs,Report,Upload
'Backup--------------存放数据库备份文件
'Images--------------存放干部的照片
'Docs----------------存放干部的审判材料
'Report--------------存放生成的各种报表文件
'Upload--------------存放导出的上报文件
'===========================================================================================
Public Sub checkDir(dir() As String)
On Error Resume Next
Dim obj As New FileSystemObject
Dim i As Integer
For i = LBound(dir) To UBound(dir) Step 1
If Not obj.FolderExists(App.path + dir(i)) Then
obj.CreateFolder App.path + dir(i)
End If
Next i
End Sub

'判断字符串中是否含有空格,单引号,双引号等特殊字符
Public Function checkInput(iStr As String) As Boolean
If InStr(iStr, " ") > 0 Or InStr(iStr, "'") > 0 Or InStr(iStr, """") > 0 Then
checkInput = False
Exit Function
Else
checkInput = True
Exit Function
End If
End Function

'FSO的几个应用函数

'1.读取文件中所有字符的函数
'其实就是通过ReadLine（读取行），通过 While Not cnrs.AtEndOfStream 的条件进行循环读取行，
'来达到读取文件中所有字符。当然也可以使用ReadAll代替多个ReadLine，但主要缺点是将格式进行换行等问题需要再次解决。
'引用函数 call FSOFileRead("xxx文件") 即可

Function FileReadAll(filename As String) As String
On Error GoTo errlabel
Dim fso As New FileSystemObject
If Not fso.FileExists(filename) Then
FileReadAll = ""
Exit Function
Else
Dim cnrs As TextStream
Dim rsline As String
rsline = ""
Set cnrs = fso.OpenTextFile(filename, 1)
While Not cnrs.AtEndOfStream
rsline = rsline & cnrs.ReadLine
Wend
FileReadAll = rsline
Exit Function
End If
errlabel:
FileReadAll = ""
End Function

'2读取文件中某一行中所有字符的函数
'这次即使用了readall方法，通过split函数将读取的内容以换行为条件，进行数组的定义，
'提取 lineNum-1（数组从0记数） 所对应的数组值即为 读取的该行值 ，也就是该行中所有的字符了。
'函数的调用 call FSOlinedit("xxx文件",35) 表示显示xxx文件的第35行内容

Function LineEdit(filename As String, lineNum As Integer) As String
On Error GoTo errlabel
If lineNum < 1 Then
LineEdit = ""
Exit Function
End If
Dim fso As New FileSystemObject
If Not fso.FileExists(filename) Then
LineEdit = ""
Exit Function
Else
Dim f As TextStream
Dim tempcnt As String
Dim temparray
Set f = fso.OpenTextFile(filename, 1)
If Not f.AtEndOfStream Then tempcnt = f.ReadAll
f.Close
Set f = Nothing
temparray = Split(tempcnt, Chr(13) & Chr(10))
If lineNum > UBound(temparray) + 1 Then
LineEdit = ""
Exit Function
Else
LineEdit = temparray(lineNum - 1)
End If
End If
Exit Function
errlabel:
LineEdit = ""
End Function

'3.读取文件中最后一行内容的函数
'其实和读取某一行的函数类似，主要即是 数组的上界ubound值 就是最末的值 ，故为最后一行。函数的引用也很简单。

Function LastLine(filename As String) As String
On Error GoTo errlabel
Dim fso As New FileSystemObject
If Not fso.FileExists(filename) Then
LastLine = ""
Exit Function
End If
Dim f As TextStream
Dim tempcnt As String
Dim temparray
Set f = fso.OpenTextFile(filename, 1)
If Not f.AtEndOfStream Then
tempcnt = f.ReadAll
f.Close
Set f = Nothing
temparray = Split(tempcnt, Chr(13) & Chr(10))
LastLine = temparray(UBound(temparray))
End If
Exit Function
errlabel:
LastLine = ""
End Function

'在ASP中自动创建多级文件夹的函数
'FSO中有个方法是CreateFolder,但是这个方法只能在其上一级文件夹存在的情况下创建新的文件夹,
'所以我就写了一个自动创建多级文件夹的函数,在生成静态页面等方面使用非常方便.
'--------------------------------
' 自动创建指定的多级文件夹
' strPath为绝对路径

Function AutoCreateFolder(strPath) As Boolean
On Error Resume Next
Dim astrPath
Dim ulngPath As Integer
Dim i As Integer
Dim strTmpPath As String

If InStr(strPath, "/") <= 0 Or InStr(strPath, ":") <= 0 Then
AutoCreateFolder = False
Exit Function
End If
Dim objFSO As New FileSystemObject
If objFSO.FolderExists(strPath) Then
AutoCreateFolder = True
Exit Function
End If
astrPath = Split(strPath, "/")
ulngPath = UBound(astrPath)
strTmpPath = ""
For i = 0 To ulngPath
strTmpPath = strTmpPath & astrPath(i) & "/"
If Not objFSO.FolderExists(strTmpPath) Then
' 创建
objFSO.CreateFolder (strTmpPath)
End If
Next
Set objFSO = Nothing
If Err = 0 Then
AutoCreateFolder = True
Else
AutoCreateFolder = False
End If
End Function