VBScript FileSystem class

A VBScript equivalent of PHP’s FileSystem class


Class File_System

    Private fso
    Private ts

    '
    'Initialize Class
    ' 
    '@access private
    '
    Private Sub Class_Initialize()
        Set fso = Server.CreateObject("Scripting.FileSystemObject")
    End Sub

    '
    'Terminate Class
    ' 
    '@access private
    '
    Private Sub Class_Terminate()
        Set fso = Nothing
    End Sub

    Function basename(path, suffix)

        Dim b
        b = preg_replace("/^.*[\/\\]/g",",path,null,null)

        If len(suffix) > 0 Then
            If Right(b,len(suffix)) = suffix Then
                b = Left(b,len(b) - len(suffix))
            End If
        End If

        basename = b

    End Function

    Public Function copy(source,dest)
        fso.CopyFile source,dest
    End Function


    Public function fclose
        ts.close
        Set ts = Nothing
    end function


    Public function feof
        feof = ts.AtEndofStream
    end function


    Public function fgetc
        If ts.AtEndofStream Then
            fgetc = false
        Else
            fgetc = ts.Read(1)
        End If
    end function


    Public Function fgetcsv(delim)

        Dim tmp,d
        If len(delim) > 0 Then d = delim Else d = ","
        tmp = ts.ReadLine
        fgetcsv = fgetcsv_helper(tmp,d)

    End Function


    Public Function fgetcsv_helper(str,d)

        Dim matchAll,key
        Dim data,field,record : field = 0 : record = 0
        ReDim data(0)

        If preg_match_all(_
        "/" & d & "|" & vbCr & "?" & vbLf & "|[^" & d & "" & vbCrLf & "][^" & d & " & vbCrLf & "]*|"(?:[^"]|"")*"/",_
        str, matchAll,PREG_PATTERN_ORDER,") Then
            For Each key In matchAll(0)
                Select Case key
                Case d
                    field = field + 1
                Case vbCrLf
                    [] data , "
                    record = record +1
                Case Else
                    If left(key,1) = "" Then
                        key = Replace(substr(key,2,-1),"","")
                    End if
                    [] data(record), key
                End Select
            Next
        End If

        fgetcsv_helper = data

    End Function


    Public function fgets
        fgets = ts.ReadLine
    end function


    Public function fgetss
        fgets = strip_tags(ts.ReadLine)
    end function


    Public Function file_exists(ByVal filename)

        file_exists = false
        filename = fileMapPath(filename)
        If fso.FileExists(filename) Then file_exists = true
        If fso.FolderExists(filename) Then file_exists = true

    End Function


    Public function file_get_contents(filename)

        Dim ts
        Dim contents

        if left(filename,7) <> "http://" and file_exists( filename ) then
            Set TS = fso.OpenTextFile( fileMapPath(filename),1)

            '空のファイルの場合、エラーになってしまう
            If TS.AtEndOfStream <> True Then
               contents = TS.ReadAll
            End If

            file_get_contents = contents
            Exit Function
        end if

        if left(filename,7) <> "http://" then
            file_get_contents = false
            Exit Function
        end if

        Dim objWinHttp
        'Set objWinHttp = Server.CreateObject("WinHttp.WinHttpRequest.5.1")
        'Set objWinHttp = Server.CreateObject("MSXML2.XMLHTTP")
        Set objWinHttp = Server.CreateObject("MSXML2.ServerXMLHTTP")

        objWinHttp.Open "GET", filename, false
        objWinHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        objWinHttp.Send
        'Response.Write objWinHttp.Status & " " & objWinHttp.StatusText

        file_get_contents = objWinHttp.ResponseText

        Set objWinHttp = Nothing

        '有効にしたエラー処理を無効にする

    end function


    Public Function fileatime(filename)

        Dim f
        filename = fileMapPath(filename)
        set f = fso.GetFile(filename)
        fileatime = f.DateLastAccessed

    End Function


    Public Function filemtime(filename)

        Dim f
        filename = fileMapPath(filename)
        set f = fso.GetFile(filename)
        filemtime = f.DateLastModified

    End Function


    Private Function fileMapPath(filename)

        Dim tmp
        tmp = Left(filename,3)
        tmp = Lcase(tmp)
        If tmp <> "d:\ and tmp <> "c:\" and left(filename,7) <> "http://" then
                fileMapPath = Server.MapPath(filename)
        Else
            fileMapPath = filename
        End If

    End Function


    Public Function filesize(filename)

        Dim f
        filename = fileMapPath(filename)
        set f = fso.GetFile(filename)
        filesize = f.Size

    End Function


    Public Function filetype(filename)

        Dim f
        filename = fileMapPath(filename)
        set f = fso.GetFile(filename)
        filetype = f.Type

    End Function


    Public function fopen(filename, mode)

        Dim filePath
        filePath = fileMapPath(filename)

        If left(filePath,len("http://")) = "http://" Then
            fopen = file_get_contents(filePath)
            Exit Function
        End If

        Select Case mode
        Case "r"
            '読み込みのみでオープンします。
            Set ts = fso.OpenTextFile(filePath,1,false)
        Case "w"
            '書き込みでオープンします。
            Set ts = fso.OpenTextFile(filePath,2,true)
        Case "a"
            '追記でオープンします。
            Set ts = fso.OpenTextFile(filePath,8,true)
        Case "x"
            '書き込みでオープンします。ファイルが存在した場合はfalseを返します。
            If is_file(filePath) Then
                fopen = false
            Else
                Set ts = fso.OpenTextFile(filePath,2,true)
            End If
        Case Else
            'empty
            ts = false
        End Select

    end function


    Public function fputcsv(fields,delimiter,enclosure)

        fputcsv = false
        If len(delimiter) = 0 Then delimiter = ","
        If len(enclosure) = 0 Then enclosure = ""

        Dim key,replaced
        For key = 0 to uBound(fields)
            replaced = false
            If inStr(fields(key),delimiter) or inStr(fields(key),enclosure) or inStr(fields(key),vbCrLf) Then
                fields(key) = Replace(fields(key),enclosure,enclosure & enclosure)
                fields(key) = enclosure & fields(key) & enclosure
            End If
        Next

        Dim str : str = join(fields,delimiter)
        ts.WriteLine str
        fputcsv = len(str)
    end function


    Public function fputs(str)
        fputs = fwrite(str)
    end function


    Public function fwrite(str)
        ts.WriteLine str
    end function


    Public Function is_dir(filename)

        Dim fn
        is_dir = false
        fn = fileMapPath(filename)

        If fso.FolderExists(fn) Then is_dir = true

    End Function


    Public Function is_file(ByVal filename)

        is_file = false
        filename = fileMapPath(filename)
        If fso.FileExists(filename) Then is_file = true

    End Function


    Public Function mkdir(ByVal pathname)

        mkdir = false
        pathname = fileMapPath(pathname)
        If not fso.FolderExists(pathname) Then
            mkdir = fso.CreateFolder(pathname)
        End If

    End Function


    Public Function pathinfo(path,options)

        Dim obj : set obj = Server.CreateObject("Scripting.Dictionary")
        Dim tmp


        obj("dirname") = dirname(path)
        obj("basename") = basename(path,")
        obj("extension") = obj("basename")

        If inStr(obj("basename"),".") Then
            tmp = Split(obj("basename"),".")
            obj("extension") = tmp( uBound(tmp) )
        End if

        obj("filename") = Replace(obj("basename"),"." & obj("extension"),")

        If len(options) > 0 Then

            If options = PATHINFO_DIRNAME Then
                pathinfo = obj("dirname")
            ElseIf options = PATHINFO_BASENAME Then
                pathinfo = obj("basename")
            ElseIf options = PATHINFO_EXTENSION Then
                pathinfo = obj("extension")
            ElseIf options = PATHINFO_FILENAME Then
                pathinfo = obj("filename")
            End if
            Exit Function
        End If

        set pathinfo = obj
    End Function


    Public Function rmdir(ByVal dirname)

        dirname = fileMapPath(dirname)
        fso.DeleteFolder dirname
        rmdir = true

    End Function
    

    Public Function unlink(ByVal filename)

        filename = fileMapPath(filename)
        fso.DeleteFile filename
        unlink = true

    End Function

End Class

Please also note that php.vbs offers community built functions and goes by the McDonald’s Theory. We’ll put online functions that are far from perfect, in the hopes to spark better contributions. Do you have one? Then please just:

Other PHP functions in the filesystem extension