Visual Basic 4 Unleashed/Visual_Basic_4_Unleashed_SAMS_Publishing_1995.iso/source/chap05/fileclas.cls

Text File | 1995-07-12 | 23.7 KB | 824 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "FileClass"
Attribute VB_Creatable = True
Attribute VB_Exposed = False
Option Explicit
#If Win32 Then
    Private Declare Function GetWindowsDirectory Lib "Kernel32" _
        Alias "GetWindowsDirectoryA" _
        (ByVal lpBuffer As String, ByVal nSize As Long) As Long
#Else
    Private Declare Function GetWindowsDirectory Lib "Kernel" _
        (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
#End If

'Mode constants
Private Const MODE_APPEND = 0
Private Const MODE_BINARY = 1
Private Const MODE_INPUT = 2
Private Const MODE_OUTPUT = 3
Private Const MODE_INIFILE = 4

'Access constants
Private Const ACCESS_READ = 0
Private Const ACCESS_WRITE = 1
Private Const ACCESS_READWRITE = 2


'Internal Property Variables
Private FilePath As String
Private FileTitle As String
Private FileName As String
Private FileMode As Integer
Private FileAccess As Integer
Private FileNumber As Integer
Private LastError As Integer

'Flag variables used only privately
Private AmOpen As Boolean
Private AmDeleted As Boolean

'Constants for trappable file I/O errors
Private Const ErrOutOfMemory = 7
Private Const ErrBadFileNameOrNumber = 52
Private Const ErrFileNotFound = 53
Private Const ErrFileAlreadyOpen = 55
Private Const ErrDeviceIO = 57
Private Const ErrFileAlreadyExists = 58
Private Const ErrDiskFull = 61
Private Const ErrBadFileName = 64
Private Const ErrTooManyFiles = 67
Private Const ErrPermissionDenied = 68
Private Const ErrDiskNotReady = 71
Private Const ErrCantRename = 74
Private Const ErrPathFileAccessError = 75
Private Const ErrPathNotFound = 76

'*****************************************************
'
'   Property Procedure
'      Path, Name, Mode, Access,
'      Length, DateTime,
'
'
'*****************************************************

Public Property Get Path() As String

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    Path = FilePath

End Property

'========================================================

Public Property Let Name(newName As String)

    If Not FileExists(FileName) Then
        Dim msg, style, answer
        msg = "The file, """ & newName & """ does not exist.  "
        msg = msg & "Create it?"
        style = vbQuestion Or vbYesNo
        answer = MsgBox(msg, style, App.Title)
        If answer = vbYes Then
            FileCreate newName
        Else
            Exit Property
        End If
    Else
        ProcessPathTitleAndName newName 'Checks for Drive, Directory, etc.
    End If

End Property

'==========================================================

Public Property Get Name() As String

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    Name = FileName

End Property

'==========================================================

Public Property Get Title() As String

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    Title = FileTitle

End Property

'===========================================================

Public Property Let Mode(NewMode As Integer)

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    If NewMode <> FileMode Then
        FileMode = NewMode
        If AmOpen Then
            Close #FileNumber
            FileOpen
        End If
    End If

End Property

'============================================================

Public Property Get Mode() As Integer

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    Mode = FileMode

End Property

'==============================================================

Public Property Let Access(NewAccess As Integer)

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    If NewAccess <> FileAccess Then
        FileAccess = NewAccess
        If AmOpen Then
            Close #FileNumber
            FileOpen
        End If
    End If

End Property

'===============================================================

Public Property Get Access() As Integer

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    Access = FileAccess

End Property

'================================================================

Public Property Get MyError() As Integer
    MyError = LastError
End Property
'================================================================

Public Property Get Length() As Long

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    Dim FileNum As Integer

    If Assert(FileName <> "", _
            "FileObject.Length:  FileName not initialized!") Then
        FileNum = FreeFile
        Open FileName For Binary Access Read As #FileNum
        Length = LOF(FileNum)
        Close FileNum
    End If

End Property

'===============================================================

Public Property Get DateTime() As Variant

    If AmDeleted Then
        DeletedMsg
        Exit Property
    End If
    If Not Assert(FileName <> "", _
            "FileObject.FileOpen:  FileName not initialized!") Then
        Exit Property
    End If
    If Assert(FileExists(FileName), _
            "FileObject.DateTime:  FileName not initialized!") Then
        DateTime = FileDateTime(FileName)
    End If

End Property

'**********************************************************
'
'    Methods
'
'      FileOpen, FileClose, FileMove, FileRename, FileDelete
'
'**********************************************************

Public Function FileOpen() As Integer

    If AmDeleted Then
        DeletedMsg
        Exit Function
    End If

    If Not Assert(FileName <> "", _
            "FileObject.FileOpen:  FileName not initialized!") Then
        Exit Function
    End If

    If AmOpen Then Close #FileNumber
    Dim dummy As Variant
    FileNumber = FreeFile
    Select Case FileMode
        Case MODE_APPEND
            Select Case FileAccess
                Case ACCESS_READ
                    dummy = Assert(False, _
                        "FileObject.FileOpen:  " & _
                        "ReadOnly Access specified for Append action!")
                    AmOpen = False
                Case ACCESS_WRITE
                    On Error GoTo FileOpenError
                        Open FileName For Append Access Write As #FileNumber
                        AmOpen = True
                        FileOpen = FileNumber
                    On Error GoTo 0
                    Exit Function
                Case ACCESS_READWRITE
                    dummy = Assert(False, _
                        "FileObject.FileOpen:  " & _
                        "ReadWrite Access specified for Append action!")
                    AmOpen = False
                Case Else
            End Select
        Case MODE_BINARY
            Select Case FileAccess
                 Case ACCESS_READ
                    On Error GoTo FileOpenError
                    Open FileName For Binary Access Write As #FileNumber
                    AmOpen = True
                    FileOpen = FileNumber
                    On Error GoTo 0
                    Exit Function
                 Case ACCESS_WRITE
                    On Error GoTo FileOpenError
                    Open FileName For Binary Access Write As #FileNumber
                    AmOpen = True
                    FileOpen = FileNumber
                    On Error GoTo 0
                    Exit Function
                Case ACCESS_READWRITE
                    On Error GoTo FileOpenError
                    Open FileName For Binary Access Read Write As #FileNumber
                    AmOpen = True
                    FileOpen = FileNumber
                    On Error GoTo 0
                    Exit Function
                Case Else
            End Select
        Case MODE_INPUT
            Select Case FileAccess
                 Case ACCESS_READ
                    On Error GoTo FileOpenError
                    Open FileName For Input Access Read As #FileNumber
                    AmOpen = True
                    FileOpen = FileNumber
                    On Error GoTo 0
                    Exit Function
                 Case ACCESS_WRITE
                    dummy = Assert(False, _
                        "FileObject.FileOpen:  " & _
                        "Attempting Access Write with Input mode!")
                    Exit Function
                Case ACCESS_READWRITE
                    dummy = Assert(False, _
                        "FileObject.FileOpen:  " & _
                        "Attempting Access Read Write with Input mode!")
                    Exit Function
                Case Else
            End Select
        Case MODE_OUTPUT
            Select Case FileAccess
                 Case ACCESS_READ
                    dummy = Assert(False, _
                        "FileObject.FileOpen: " & _
                        "Attempting Access Read with Output mode!")
                    Exit Function
                 Case ACCESS_WRITE
                    On Error GoTo FileOpenError
                    Open FileName For Output Access Write As #FileNumber
                    AmOpen = True
                    FileOpen = FileNumber
                    On Error GoTo 0
                    Exit Function
                Case ACCESS_READWRITE
                    dummy = Assert(False, _
                        "FileObject.FileOpen:  " & _
                        "Attempting Access Read Write with Output mode!")
                    Exit Function
                Case Else
            End Select
        Case Else
            dummy = Assert(False, _
                "FileObject.FileOpen:  " & _
                "Incorrect File Mode parameter set!")
            Exit Function
    End Select
FileOpenError:
    Dim action As Integer, ErrNumber As Integer
    action = Errors()
    Select Case action
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2, 3
            Exit Function
        Case Else
            ErrNumber = Err.Number
            Err.Raise ErrNumber
            Err.Clear
    End Select

End Function

'=========================================================

Public Sub FileClose()

    If AmDeleted Then
        DeletedMsg
        Exit Sub
    End If

    If Not Assert(FileName <> "", _
        "FileObject.FileOpen:  FileName not initialized!") Then
        Exit Sub
    End If

    If AmOpen Then
        Close #FileNumber
        FileNumber = 0
        AmOpen = False
    End If

End Sub

'========================================================

Public Sub FileMove(NewPath As String)

    If Not Assert(FileName <> "", _
        "FileObject.FileMove:  FileName not initialized!") Then
        Exit Sub
    End If

    'Check Drive Spec
    Dim newName As String, SourceNum As Integer, TargetNum As Integer
    If VBA.Right$(NewPath, 1) = "\" Then   'Get the path in shape
        newName = NewPath & FileTitle
    Else
        newName = NewPath & "\" & FileTitle
    End If
    If InStr(NewPath, ":") Then   'There is a drive spec included
        If VBA.Left$(newName, 1) <> VBA.Left$(FileName, 1) Then
            'Different drive, Name command won't work
            DoFileCopy FileName, newName
            Kill FileName
            ProcessPathTitleAndName newName
        End If
    Else
        On Error GoTo FileMoveError
        Name FileName As newName
        On Error GoTo 0
        ProcessPathTitleAndName newName
    End If
    Exit Sub

FileMoveError:
    Dim action As Integer, ErrNumber As Integer
    action = Errors()
    Select Case action
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2, 3
            Exit Sub
        Case Else
            ErrNumber = Err.Number
            Err.Raise ErrNumber
            Err.Clear
    End Select

End Sub

'==============================================================

Public Sub FileRename(newName As String)

    If Not Assert(FileName <> "", _
        "FileObject.FileRename:  FileName not initialized!") Then
        Exit Sub
    End If

    On Error GoTo FileRenameError
    If InStr(newName, ":") Then  'there is a drive spec
        If VBA.Left$(newName, 1) <> VBA.Left$(FileName, 1) Then
            DoFileCopy FileName, newName
            Kill FileName
        Else
            Name FileName As newName
        End If
    Else
        Name FileName As newName
    End If
    On Error GoTo 0
    ProcessPathTitleAndName newName

FileRenameError:
    Dim action As Integer, ErrNumber As Integer
    action = Errors()
    Select Case action
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2, 3
            Exit Sub
        Case Else
            ErrNumber = Err.Number
            Err.Raise ErrNumber
            Err.Clear
    End Select

End Sub

'===============================================================

Public Sub FileDelete()

    If Not Assert(FileName <> "", _
        "FileObject.FileOpen:  FileName not initialized!") Then
        Exit Sub
    End If

    If AmOpen Then Close #FileNumber
    If AmDeleted Then
        DeletedMsg
        Exit Sub
    End If

    Kill FileName

    AmDeleted = True
    FileNumber = 0


End Sub

'===================================================

Public Sub FileCreate(newName As String)

    Dim FileNum As Integer
    Dim choice As Integer

    FileNum = FreeFile
    Open newName For Output As #FileNum
    Close FileNum

    ProcessPathTitleAndName newName
    AmDeleted = False

End Sub

'===================================================

Public Sub FileCopy(newName As String, Optional RegisterNew As Variant)

    If Not Assert(FileName <> "", _
        "FileObject.FileOpen:  FileName not initialized!") Then
        Exit Sub
    End If

    DoFileCopy FileName, newName

    If Not IsMissing(RegisterNew) And RegisterNew = True Then
        ProcessPathTitleAndName newName
    End If

End Sub

'=====================================================

Private Function Errors() As Integer

    Dim MsgType As Integer, msg As String, response As Integer
    Dim NewFileNameNeeded As Boolean
    Dim DoResume As Boolean
    Dim DoResumeNext As Boolean
    'Return Value     Meaning     Return Value     Meaning
    '      0          Resume            2          Filename Error
    '      1          Resume Next       3          Unrecoverable Error
    '                                   4          Unrecognized Error
    MsgType = vbExclamation
    Select Case Err.Number
        Case ErrOutOfMemory '7
            msg = "The operating system reports that there is not "
            msg = msg & "enough memory to complete this operation.  "
            msg = msg & "You can try closing some other applications and then "
            msg = msg & "click Retry to try again or you can click Cancel to exit."
            MsgType = vbExclamation + vbRetryCancel
            DoResume = True
            'Resume or Exit
        Case ErrBadFileNameOrNumber, ErrBadFileName
            msg = "That file name is illegal!"
            NewFileNameNeeded = True
            DoResume = True
            'Resume
        Case ErrFileNotFound
            msg = "That file does not exist.  Create it?"
            MsgType = vbExclamation + vbOKCancel
            DoResumeNext = True
            'Resume Next
        Case ErrFileAlreadyOpen
            msg = "That file is already in use."
            MsgType = vbExclamation + vbRetryCancel
            NewFileNameNeeded = True
            'New Name
        Case ErrDeviceIO
            msg = "Internal disk error."
            MsgType = vbExclamation + vbRetryCancel
            DoResume = True
            'Resume
        Case ErrFileAlreadyExists
            msg = "A file with that name already exists.  "
            msg = msg & "Replace it?"
            MsgType = vbExclamation + vbOKCancel
            NewFileNameNeeded = True
            'New Name
        Case ErrDiskFull
            msg = "This disk is full.  Continue?"
            MsgType = vbExclamation + vbOKCancel
            DoResume = True
            'Resume
        Case ErrTooManyFiles
            msg = "The operating system reports that too "
            msg = msg & "many files are currently open.  You "
            msg = msg & "can try closing some other applications "
            msg = msg & "and then try again."
            MsgType = vbExclamation + vbRetryCancel
            DoResume = True
            'Resume
        Case ErrPermissionDenied
            msg = "You have tried to write to a file that is in "
            msg = msg & "use or is designated as read-only."
            NewFileNameNeeded = True
            'New Name
        Case ErrDiskNotReady
            msg = "Insert a disk in the drive and close the door"
            MsgType = vbExclamation + vbOKCancel
            DoResume = True
            'Resume
        Case ErrPathFileAccessError, ErrPathNotFound
            msg = "The operating system cannot locate this file on "
            msg = msg & "this path.  Check to make sure that the file "
            msg = msg & "name and path have been entered correctly "
            msg = msg & "and then try again."
            NewFileNameNeeded = True
        Case Else
            Errors = 4
            Exit Function
    End Select
    response = MsgBox(msg, MsgType, "File Error")
    Select Case response
        Case vbRetry, vbOK
            If NewFileNameNeeded Then
                LastError = FOBJ_ERROR_FILENAME
            ElseIf DoResume Then
                LastError = FOBJ_ERROR_RESUME
            ElseIf DoResumeNext Then
                LastError = FOBJ_ERROR_RESUMENEXT
            Else
                LastError = FOBJ_ERROR_UNRECOVERABLE
            End If
        Case Else
            LastError = FOBJ_ERROR_UNRECOGNIZABLE
    End Select
    Errors = LastError

End Function

'===========================================================

Private Function FileExists(theName As String) As Boolean
    FileExists = (Dir(theName) <> "")
End Function

'**********************************************************
'
'    Private Utility Functions
'
'
'
'**********************************************************

Private Sub ProcessPathTitleAndName(newName As String)

   Dim BackSlash As Integer
   If InStr(newName, "\") Then
        BackSlash = RInstr(0, newName, "\")
        FilePath = VBA.Left$(newName, BackSlash - 1)
        FileTitle = Mid$(newName, BackSlash + 1)
    ElseIf InStr(newName, ":") Then
        Dim CurDrive As String
        Dim TargetDrive As String
        TargetDrive = VBA.Left$(newName, 1)
        CurDrive = CurDir$
        If VBA.Left$(CurDrive, 1) <> TargetDrive Then
            ChDrive TargetDrive
            FilePath = CurDir$
            ChDrive CurDrive
        Else
            FilePath = CurDir$
        End If
        FileTitle = Mid$(newName, InStr(newName, ":") + 1)
    Else
        FilePath = CurDir$
        FileTitle = newName
    End If
    FileName = FilePath & "\" & FileTitle

End Sub

'=======================================================

Private Sub DoFileCopy(Source As String, Target As String, _
        Optional Overwrite As Variant)

    Dim ErrorMsg As String, SourceNum As Integer, TargetNum As Integer
    Dim buffer As String, TheLength As Long

    ErrorMsg = "FileObject.DoFileCopy: Attempting "
    ErrorMsg = ErrorMsg & "copy/move operation on non-existent file!"
    If Assert(FileExists(Source), ErrorMsg) Then
        SourceNum = FreeFile: TargetNum = FreeFile
        On Error GoTo DoFileCopyError
        Open Source For Binary Access Read As SourceNum
        On Error GoTo 0
        If FileExists(Target) Then
            If IsMissing(Overwrite) Or Overwrite = False Then
                'Get confirmation
                Dim msg As String, style As Integer, answer As Integer
                msg = "The file, """ & Source & """ already exists.  "
                msg = msg & "This action will overwrite it.  Continue?"
                style = vbQuestion & vbYesNo
                answer = MsgBox(msg, style, App.Title)
                If answer = vbNo Then
                    Exit Sub
                End If
            End If
        End If
        TheLength = LOF(SourceNum)
        On Error GoTo DoFileCopyError
            Open Source For Binary Access Read As SourceNum
            Open Target For Binary Access Write As TargetNum
        On Error GoTo 0
        If TheLength < 60000 Then
            'Take the file in bits
            Do Until TheLength < 60000
                buffer = String$(0, 60000)
                Get SourceNum, , buffer
                Put TargetNum, , buffer
                TheLength = TheLength - Len(buffer)
            Loop
            buffer = String$(0, TheLength)
            Get SourceNum, , buffer
            Put TargetNum, , buffer
        Else
            buffer = String$(0, TheLength)
            Get #SourceNum, , buffer
            Put TargetNum, , buffer
        End If
        Close #SourceNum
        Close #TargetNum
    End If
    Exit Sub

DoFileCopyError:
    Dim action As Integer, ErrNumber As Integer
    action = Errors()
    Select Case action
        Case 0
            Resume
        Case 1
            Resume Next
        Case 2, 3
            Exit Sub
        Case Else
            ErrNumber = Err.Number
            Err.Raise ErrNumber
            Err.Clear
    End Select

End Sub

'============================================================

Sub DeletedMsg()

    Dim msg, style
    msg = "You have deleted the file """ & FileName & "."""
    msg = msg & "  You must reinitialize the FileObject with a "
    msg = msg & "new valid file name before proceeding!"
    style = vbCritical + vbOKOnly
    MsgBox msg, style, App.Title

End Sub

'========================================================

Private Function OverwriteWarning(FileName As String) As Integer

    Dim msg As String, style As Integer

    msg = "The file, " & FileName & ", already exists in the current "
    msg = msg & "directory.  Overwrite it?"
    style = vbQuestion Or vbYesNo
    OverwriteWarning = MsgBox(msg, style, App.Title)

End Function

'=========================================================

Private Function RInstr(Start As Integer, Source As String, _
    Goal As String) As Integer

    Dim Index As Integer, N As Integer

    If Start <> 0 Then Index = Start Else Index = Len(Source)
    For N = Index To 1 Step -1
        If Mid$(Source, N, 1) = Goal Then
            RInstr = N
            Exit Function
        End If
    Next
    RInstr = 0

End Function

'**********************************************************
'
'    Class Initialization and Destruction
'
'
'
'**********************************************************

Private Sub Class_Initialize()

    Dim nResult As Integer
    Dim buffer As String

    'Initializes the object to an ubiquitous file
    'This works in tandem with the inifile object
    'by setting things to point to WIN.INI
    FileTitle = "WIN.INI"
    buffer = String$(200, 0)
    nResult = GetWindowsDirectory(buffer, Len(buffer))
    FilePath = VBA.Left$(buffer, nResult)
    FileName = FilePath & "\" & FileTitle
    FileMode = MODE_BINARY
    FileAccess = ACCESS_READWRITE

End Sub




Private Sub Class_Terminate()
    If FileNumber <> 0 Then
        Close #FileNumber
    End If
End Sub