Keskustelu: Koodit: VB6: Salasana tiedoston hallinta salauksineen

Option Explicit
' Käyttää CAPICOM 2.0 encryptaus kirjastoa (ladattavissa microsoftilta ilmaiseksi)
' Käyttää Microsoft Scripting Runtime kirjastoa (ladattavissa microsoftilta ilmaiseksi)

'CAPICOM.EncryptedData
'Scripting.Dictionary
'Scripting.FileSystemObject

Private MsgObj As New EncryptedData
Public Key As String
Public oDict As New Dictionary
Private mvarDelimiter As String
Private mvarFilePath As String
Private mvarErrNumber As Long
Private mvarErrDescription As String
Private mvarErrSource As String
Private mvarSessionKey As String
'**********************************************************************
' Property:     SessionKey
' Definition:   Secret key used for encryption
'**********************************************************************
Public Property Let SessionKey(ByVal vData As String)
    mvarSessionKey = vData
End Property

Public Property Get SessionKey() As String
    SessionKey = mvarSessionKey
End Property
'**********************************************************************
' Property:     ErrSource,ErrDescription,ErrNumber
' Definition:   Error management preperties
'**********************************************************************
Public Property Let ErrSource(ByVal vData As String)
    mvarErrSource = vData
End Property

Public Property Get ErrSource() As String
    ErrSource = mvarErrSource
End Property

Public Property Let ErrDescription(ByVal vData As String)
    mvarErrDescription = vData
End Property

Public Property Get ErrDescription() As String
    ErrDescription = mvarErrDescription
End Property

Public Property Let ErrNumber(ByVal vData As Long)
    mvarErrNumber = vData
End Property

Public Property Get ErrNumber() As Long
    ErrNumber = mvarErrNumber
End Property
'**********************************************************************
' Property:     FilePath
' Definition:   FilePath of file to open
'**********************************************************************
Public Property Let FilePath(ByVal vData As String)
    mvarFilePath = vData
End Property

Public Property Get FilePath() As String
    FilePath = mvarFilePath
End Property
'**********************************************************************
' Property:     Delimiter
' Definition:   Delimiter used to delimit username and password in file
'**********************************************************************
Public Property Let Delimiter(ByVal vData As String)
    mvarDelimiter = vData
End Property

Public Property Get Delimiter() As String
    Delimiter = mvarDelimiter
End Property
'**********************************************************************
' Method:       ReadFile
' Definition:   Reads a file from path declared in FilePath - property
'**********************************************************************
Public Function ReadFile() As Boolean
    Dim objFile As New FileSystemObject
    Dim tsTextIn As TextStream
    Dim strData As String
    Dim strFileData() As String
On Error GoTo ErrHandler
    If objFile.FileExists(FilePath) Then
        Set tsTextIn = objFile.OpenTextFile(mvarFilePath, ForReading, False)
        Do While Not tsTextIn.AtEndOfStream
            If IsEmpty(mvarSessionKey) Then
                strFileData = Split(tsTextIn.ReadLine, mvarDelimiter)
            Else
                strData = tsTextIn.ReadLine
                strData = strData & tsTextIn.ReadLine
                strData = strData & tsTextIn.ReadLine
                tsTextIn.ReadLine
                strFileData = Split(DecryptMessage(strData, mvarSessionKey), mvarDelimiter)
            End If
            oDict.Add strFileData(0), strFileData(1)
        Loop
        tsTextIn.Close
       ReadFile = True
    Else
        Err.Raise -1, "ReadFile", "Tiedostoa ei löytynyt"
    End If
Exit Function
ErrHandler:
    ReadFile = False
    HandleErrors Err
End Function
'**********************************************************************
' Method:       WriteFile
' Definition:   Writes a file to path declared in FilePath - property
'**********************************************************************
Public Function WriteFile() As Boolean
    Dim objFile As New FileSystemObject
    Dim tsTextOut As TextStream
    Dim strFileData As String
    Dim Key As Variant
On Error GoTo ErrHandler
    Set tsTextOut = objFile.OpenTextFile(mvarFilePath, ForWriting, True)
    For Each Key In oDict.Keys
        If IsEmpty(mvarSessionKey) Then
            tsTextOut.WriteLine Key & mvarDelimiter & oDict(Key)
        Else
            tsTextOut.WriteLine EncryptMessage(Key & mvarDelimiter & oDict(Key), mvarSessionKey)
        End If
    Next
    tsTextOut.Close
Exit Function
ErrHandler:
    WriteFile = False
    HandleErrors Err
End Function
'**********************************************************************
' Method:       CheckPassword
' Definition:   Validates a password
'**********************************************************************
Public Function CheckPassword(strUserName As String, strPassword As String) As Boolean
On Error GoTo ErrHandler
    If Trim(strUserName) = "" Or Trim(strPassword) = "" Then Err.Raise -3, "CheckPassword", "Tyhjä parametri"
    If oDict.Exists(strUserName) Then
        If oDict(strUserName) = strPassword Then
            CheckPassword = True
        Else
            CheckPassword = False
        End If
    Else
        CheckPassword = False
    End If
Exit Function
ErrHandler:
    CheckPassword = False
    HandleErrors Err
End Function
'**********************************************************************
' Method:       ChangeUserData
' Definition:   Changes a value or key name in username/password dictionary
'**********************************************************************
Public Function ChangeUserData(strOldUserName As String, strNewUserName As String, strPassword As String, Optional bSaveToFile As Boolean = True) As Boolean
On Error GoTo ErrHandler
    If Trim(strNewUserName) = "" Or Trim(strNewUserName) = "" Or Trim(strPassword) = "" Then Err.Raise -3, "ChangeUserData", "Tyhjä parametri"
    If oDict.Exists(strOldUserName) Then
        If strOldUserName <> strNewUserName Then
            oDict.Add strNewUserName, strPassword
            oDict.Remove strOldUserName
        Else
            oDict(strOldUserName) = strPassword
        End If
        If bSaveToFile Then WriteFile
        ChangeUserData = True
    Else
        Err.Raise -2, "SaveUserData", "Muutettavaa käyttäjätunnusta ei löydy:" & strOldUserName
    End If
Exit Function
ErrHandler:
    ChangeUserData = False
    HandleErrors Err
End Function
'**********************************************************************
' Method:       AddUserData
' Definition:   Adds a new key a key to Username/Password dictionary
'**********************************************************************
Public Function AddUserData(strUserName As String, strPassword As String, Optional bSaveToFile As Boolean = True) As Boolean
On Error GoTo ErrHandler
    If Trim(strUserName) = "" Or Trim(strPassword) = "" Then Err.Raise -3, "AddUserData", "Tyhjä parametri"
    If Not oDict.Exists(strUserName) Then
        oDict.Add strUserName, strPassword
        If bSaveToFile Then WriteFile
        AddUserData = True
    Else
        Err.Raise -2, "AddUserData", "Käyttäjätunnus on jo varattu:" & strUserName
    End If
Exit Function
ErrHandler:
    AddUserData = False
    HandleErrors Err
End Function
'**********************************************************************
' Method:       DeleteUserData
' Definition:   Deletes a key from Username/Password dictionary
'**********************************************************************
Public Function DeleteUserData(strUserName As String, Optional bSaveToFile As Boolean = True) As Boolean
On Error GoTo ErrHandler
    If Trim(strUserName) = "" Then Err.Raise -3, "AddUserData", "Tyhjä parametri"
    If Not oDict.Exists(strUserName) Then
        oDict.Remove strUserName
        If bSaveToFile Then WriteFile
        DeleteUserData = True
    Else
        Err.Raise -2, "AddUserData", "Käyttäjätunnus on jo varattu:" & strUserName
    End If
Exit Function
ErrHandler:
    DeleteUserData = False
    HandleErrors Err
End Function
'**********************************************************************
' Method:       HandleErrors
' Definition:   Global error manager - saves error log to appilication path
'**********************************************************************
Private Function HandleErrors(oErr As ErrObject)
    Dim oErrFile As New FileSystemObject
    Dim tsErrors As TextStream
    Me.ErrNumber = oErr.Number
    Me.ErrDescription = oErr.Description
    Me.ErrSource = oErr.Source
    Set tsErrors = oErrFile.OpenTextFile(App.Path & "\ErrLog.txt", ForWriting, True)
    tsErrors.WriteLine Now() & " : " & oErr.Number & " : " & oErr.Source & " : " & oErr.Description
    tsErrors.Close
End Function

'**********************************************************************
' Method:       DecryptMessage
' Definition:   Decrypts messages sent to system
'**********************************************************************
Private Function DecryptMessage(ByVal strMessage As String, ByVal Session As String, Optional ByVal Algorithm As Integer = 1) As String
    On Error GoTo ErrHandler:
        Set MsgObj = New EncryptedData
        MsgObj.SetSecret Session
        MsgObj.Algorithm.Name = GetAlgorithm(Algorithm)
        MsgObj.Decrypt strMessage
        DecryptMessage = MsgObj.Content
        mvarErrNumber = 0
    Exit Function
ErrHandler:
    DecryptMessage = "-1"
    HandleErrors Err
End Function
'**********************************************************************
' Method:       EncryptMessage
' Definition:   Encrypts messages sent to system
'**********************************************************************
Private Function EncryptMessage(ByVal strMessage As String, ByVal Session As String, Optional ByVal Algorithm As Integer = 1) As String
    On Error GoTo ErrHandler:
        Set MsgObj = New CAPICOM.EncryptedData
        MsgObj.SetSecret Session
        MsgObj.Content = strMessage
        MsgObj.Algorithm.Name = GetAlgorithm(Algorithm)
        EncryptMessage = MsgObj.Encrypt
        mvarErrNumber = 0
    Exit Function
ErrHandler:
    EncryptMessage = "-1"
    HandleErrors Err
End Function
Private Function GetAlgorithm(iAlg As Integer) As CAPICOM_ENCRYPTION_ALGORITHM
    Select Case iAlg
        Case 0
            GetAlgorithm = CAPICOM_ENCRYPTION_ALGORITHM_3DES
        Case 1
            GetAlgorithm = CAPICOM_ENCRYPTION_ALGORITHM_DES
        Case 2
            GetAlgorithm = CAPICOM_ENCRYPTION_ALGORITHM_RC2
        Case 3
            GetAlgorithm = CAPICOM_ENCRYPTION_ALGORITHM_RC4
    End Select
End Function

Private Sub Class_Terminate()
    If Not MsgObj Is Nothing Then Set MsgObj = Nothing
End Sub

Dim pwd As New Password
Private Sub Form_Load()
    Set pwd = New Password
    pwd.SessionKey = "Salasana"
    pwd.Delimiter = ";"
    pwd.FilePath = App.Path & "\PwdFile.dat"
    If Not pwd.ReadFile Then
        MsgBox "Virhe ladattaessa salasanoja"
    End If
End Sub
Private Sub cmdManage_Click(Index As Integer)
    Select Case Index
    Case 0
        If Not pwd.AddUserData(txtUserName.Text, txtPassword.Text) Then
            MsgBox "Virhe lisättäessä salasanaa:" & pwd.ErrDescription
        End If
    Case 1
        If Not pwd.DeleteUserData(txtUserName.Text) Then
            MsgBox "Virhe poistettaessa salasanaa: " & pwd.ErrDescription
        End If
    Case 2
        If Not pwd.ChangeUserData(txtUserName.Text, txtNewUserName.Text, txtPassword.Text) Then
            MsgBox "Virhe muokattaessa salasanaa: " & pwd.ErrDescription
        End If
    Case 3
        pwd.WriteFile
    Case 4
        If Not pwd.CheckPassword(txtUserName.Text, txtPassword.Text) Then
            MsgBox "Väärä käyttäjätunnus tai salasana"
        Else
            MsgBox "Oikea salasana"
        End If
    End Select
End Sub
Private Sub Form_Unload(Cancel As Integer)
    pwd.WriteFile
End Sub