clsfilehandler.cls

这个类提供了一个快速和更简单的方式来使用RC4算法来加密和解密文件。它也包括了用来打开

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsFileHandler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Title: clsFileHandler
' Purpose: A complete File handling solution, viz., reading,
'   writing, appending, encrypting, and decrypting
'
' Example: Create an object of the class
'       Dim myFileObj as new clsFileHandler.
'       myFileObj.FileName=app.path & "\q.txt"
'       myFileObj.saveStringToFile "message to save"
' you can also use writeDataFile to write to file.
' Similarly, you can use various other function available. For more
' help, see the individual descriptions of the functions.
' For more, see the test form included in this project.
'
' /////////////
' Adaptations:
' /////////////
'   The class module clsRC4.cls is not mine and has been adapted
'   from VBCrypto Library available on FreeVBCode.com.
'
' ///////////////////
' Copyright:
'   You are free to use this code commercially as well as
'   commercially. Sooner or later, I will come up with the
'   documentation of this class module as now I'm busy in my exams
'   of B.Tech (Bachelor of Technology) in Computer Science and
'   Engineering.
' //////////////////
'
' //////////////////////
' Author: Amit Bhandari
' Date:   26 May, 2003
' /////////////////////
'
' Story Behind Class Module:
'   On 19th of May, I was working on my Payroll project and I feel
'  the need for adding some file handling to my project for
'  generating automatic serial numbers of the employees. I browsed
'  FreeVbCode.com, but couldn't find anything related to this in a
'  single module. So, I determined to submit my first code to
'  freevbcode.com to help those people like me who wake up only when
'  some serious problem has occured.
'
'
'Project Log
'# 21 May, 2003
'       - Started writing the clsFileHandler
'       - Written the file writing and reading functions
'
'# 23 May, 2003
'       - Created a new function for appending data
'
'# 25 May, 2003
'       - Thought of adding Encryption and Decryption in the
'         handler.
'       - Found VBCrypto on freevbcode.com
'
'#26 May, 2003
'       - Written Encryption and Decryption Functions.





'local variable(s) to hold property value(s)
Private mvarfileName As String 'local copy

'Custom Variables
Private Const ForWriting = 2
Private Const ForAppending = 8
Dim F, fs, sDate, sTime, MsgType
Dim strData As String, Msg As String

Private sFile As String
Private sTitle As String
Private HC As New Collection

'CopyFile API Call
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
    (ByVal lpExistingFileName As String, ByVal lpNewFileName As _
    String, ByVal bFailIfExists As Long) As Long

'The Object of RC4 Algorithm implementation class.
Private myCryptoObj As New clsRC4

Public Function DecryptFileN(ByVal strTargetFolderWithoutSlash, ByVal strPasswdToRecover As String) As Boolean
    ' Purpose: Decrypts an already encrypted file.
    ' Example: DecryptFileN App.Path, "mypasswordKey"
    '
    ' Warning: Before using this function, set the FileName property
    ' to some file, otherwise some error box will be generated by the
    ' class module.
    '
    ' The code is well indented, so lesser comments are included in
    ' the code itself.
    '
    On Error GoTo errHandler
    Dim countSplit As Integer, strFileName As String, pathToFile As String
    Dim fileName1
    
    If Filename = "" Then
        DecryptFileN = False
        Exit Function
    End If
    
    fileName1 = Split(Filename, "\")
    countSplit = (UBound(fileName1))
    fileName1 = fileName1(countSplit)
    strFileName = fileName1
    fileName1 = Left(fileName1, Len(fileName1) - 4) + "DeCrYpteD"
    
    DecryptFileN = myCryptoObj.DecryptFile(Filename, strTargetFolderWithoutSlash & "\" & fileName1, True, strPasswdToRecover)
    
    'Re-write the original file.
    pathToFile = Left(Filename, Len(strFileName))
    CopyFile strTargetFolderWithoutSlash & "\" & fileName1, Filename, False
    Kill strTargetFolderWithoutSlash & "\" & fileName1
    
    Exit Function
errHandler:
    DecryptFileN = False
    MsgBox "An error has occured while decrypting the file.", vbOKOnly + vbCritical, "File Error"
End Function

Public Function EncryptFile(ByVal strTargetFolderWithoutSlash As String, ByVal strPasswdToSet As String) As Boolean
    ' Purpose: Encrypts a file.
    ' Example: EncryptFile App.Path, "mypasswordKey"
    '
    ' Warning: Before using this function, set the FileName property
    ' to some file, otherwise some error box will be generated by the
    ' class module.
    '
    ' The code is well indented, so lesser comments are included in
    ' the code itself.
    '
    
    On Error GoTo errHandler
    Dim countSplit As Integer, strFileName As String, pathToFile As String
    Dim fileName1
    
    If Filename = "" Then
        EncryptFile = False
        Exit Function
    End If
    
    fileName1 = Split(Filename, "\")
    countSplit = (UBound(fileName1))
    fileName1 = fileName1(countSplit)
    strFileName = fileName1
    fileName1 = Left(fileName1, Len(fileName1) - 4) + "enCrYpteD"
    
    EncryptFile = myCryptoObj.EncryptFile(Filename, strTargetFolderWithoutSlash & "\" & fileName1, True, strPasswdToSet)
    
    'Re-write the original file.
    pathToFile = Left(Filename, Len(strFileName))
    CopyFile strTargetFolderWithoutSlash & "\" & fileName1, Filename, False
    Kill strTargetFolderWithoutSlash & "\" & fileName1
    
    Exit Function
errHandler:
    EncryptFile = False
    MsgBox "An error occured while encrypting the file.", vbOKOnly + vbCritical, "File Error"
End Function

Private Function writeDataFile(ByVal theDataToSave As String) As Boolean
    ' Purpose: Write string to a file.
    ' Example: writeDataFile "the string to be saved is here."
    '
    ' * Please prefer saveStringtoFile rather than this function.
    ' Warning: Before using this function, set the FileName property
    ' to some file, otherwise some error box will be generated by the
    ' class module.
    '
    ' The code is well indented, so lesser comments are included in
    ' the code itself.
    '
    On Error GoTo errHandler
    
    Set F = fs.OpenTextFile(Filename, ForWriting, True)
    F.Write theDataToSave
    F.Close
    
    writeDataFile = True
    
    Exit Function
errHandler:
    writeDataFile = False
    MsgBox "Some error has occured while operating on file.", vbOKOnly + vbCritical, "File Error"
End Function

Public Function readStringFromFile(Optional ByVal dwdLineNumberToRead As Long = 1) As String
    ' Purpose: reads string from a file.
    ' Example: readStringFromFile 1
    '
    ' Warning: Before using this function, set the FileName property
    ' to some file, otherwise some error box will be generated by the
    ' class module.
    '
    ' The code is well indented, so lesser comments are included in
    ' the code itself.
    '
    On Error GoTo errHandler
    Dim nextContext As String
    Dim tmp, Temp1, Temp2, Temp3, fPath
    Dim FF As Long
    
    FF = FreeFile
    Open Filename For Input As FF
    While Not EOF(FF)
        Line Input #FF, nextContext
        HC.Add nextContext
    Wend
    Close FF
    
    readStringFromFile = HC.Item(dwdLineNumberToRead)
    
    Exit Function
errHandler:
    readStringFromFile = 0
    MsgBox "File read error." & Chr(13) & "Please make sure proper access rights are available to read the file.", vbOKOnly + vbCritical, "File Error"
End Function

Public Function appendStringToFile(ByVal strStringToAppend As String) As Long
    ' Purpose: Appends string line to a file.
    ' Example: readStringFromFile "anotherString"
    '
    ' * The string will be automatically be appended in the nextline
    '   of the file.
    ' Warning: Before using this function, set the FileName property
    ' to some file, otherwise some error box will be generated by the
    ' class module.
    '
    ' The code is well indented, so lesser comments are included in
    ' the code itself.
    '
    On Error GoTo errHandler
    
    If Filename = "" Then
        MsgBox "No file name was set. Please, recheck the file handling statements", vbOKOnly + vbCritical, "No File Status"
        Exit Function
    End If
    
    Set F = fs.OpenTextFile(Filename, ForAppending)
    F.Write strStringToAppend & vbCrLf
    F.Close
    
    appendStringToFile = 1
    
    Exit Function
errHandler:
    appendStringToFile = 0
    MsgBox "Some error has occured while operating on file.", vbOKOnly + vbCritical, "File Error"
End Function

Public Function saveStringToFile(ByVal strValueToAdd As String) As Long
    ' Purpose: Write string to a file.
    ' Example: writeDataFile "the string to be saved is here."
    '
    ' * Please prefer this function rather than writeDataToFile function.
    ' Warning: Before using this function, set the FileName property
    ' to some file, otherwise some error box will be generated by the
    ' class module.
    '
    ' The code is well indented, so lesser comments are included in
    ' the code itself.
    '
    On Error GoTo errHandler
    
    If Filename = "" Then
        MsgBox "No file name was set. Please, recheck the file handling statements", vbOKOnly + vbCritical, "No File Status"
        Exit Function
    End If
    
    Set F = fs.OpenTextFile(Filename, ForWriting, True)
    F.Write strValueToAdd & vbCrLf
    F.Close
    
    saveStringToFile = 1
    
    Exit Function
errHandler:
    saveStringToFile = 0
    MsgBox "Some error has occured while operating on file.", vbOKOnly + vbCritical, "File Error"
End Function

Public Property Let Filename(ByVal vData As String)
    'used when assigning a value to the property, on the left side of an assignment.
    'Syntax: X.fileName = 5
    mvarfileName = vData
End Property


Public Property Get Filename() As String
    'used when retrieving value of a property, on the right side of an assignment.
    'Syntax: Debug.Print X.fileName
    Filename = mvarfileName
End Property

Private Function readWholeFile() As String
    On Error GoTo errHandler
    Dim gf, ts
    
    Set gf = fs.GetFile(Filename)
    Set ts = gf.OpenTextStream(1, -2)
    strData = ts.ReadAll
    ts.Close
    
    readWholeFile = strData
    
    Exit Function
errHandler:
    'Nothing to do
End Function

Private Sub Class_Initialize()
    On Error Resume Next
    
    Set fs = CreateObject("Scripting.FileSystemObject")
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    
    Set F = Nothing
    Set fs = Nothing
End Sub