eigene Passworte verschluesseln

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: eigene Passworte verschluesseln von: manfred
Geschrieben am: 27.02.2005 17:33:03

Ich möchte eigene Passwörter in der Excel Datei verwalten, die ich dann über einen Eingabedialog abfrage

Spalte A____Spalte B
Name________Passwort
xyz_________abc
mnb_________asdf

allerdings sollen die Passworte nicht im klartext in der Datei erscheinen.
Mir ist klar, dass ich die Spalte passwort ausblenden kann, die Tabelle verstecken kann etc. oder ich auch das Passwort in "wingdings" darstellen kann.
Es wäre mir aber lieber, es wäre "richtig verschlüsselt". Hat jemand ein VBA Modul oder eine Idee zum schnellen ver- und entschlüsseln? Vielleicht einfach binär darstellen ?
Wäre prima
Manfred

Bild


Betrifft: AW: eigene Passworte verschluesseln von: Nepumuk
Geschrieben am: 27.02.2005 17:41:08

Hallo Mafred,

wie wäre es mit RADIX64


Option Explicit

Private aDecTab(0 To 255) As String
Private Const sEncTab As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Sub test()
    MsgBox EncodeStr64("Nepumuk")
    MsgBox DecodeStr64("TmVwdW11aw==")
End Sub

Public Function EncodeStr64(sInput As StringAs String
    Dim sOutput As String, sLast As String
    Dim b(0 To 2) As String
    Dim As Byte
    Dim As Integer, nLen As Integer, nQuants As Integer
    Dim iIndex As Integer
    nLen = Len(sInput)
    nQuants = nLen \ 3
    sOutput = ""
    iIndex = 0
    For i = 0 To nQuants - 1
        For j = 0 To 2
            b(j) = Asc(Mid(sInput, (i * 3) + j + 1, 1))
        Next
        sOutput = sOutput & EncodeQuantum(b)
        iIndex = iIndex + 4
    Next
    Select Case nLen Mod 3
        Case 0
            sLast = ""
        Case 1
            b(0) = Asc(Mid(sInput, nLen, 1))
            b(1) = 0
            b(2) = 0
            sLast = EncodeQuantum(b)
            sLast = Left(sLast, 2) & "=="
        Case 2
            b(0) = Asc(Mid(sInput, nLen - 1, 1))
            b(1) = Asc(Mid(sInput, nLen, 1))
            b(2) = 0
            sLast = EncodeQuantum(b)
            sLast = Left(sLast, 3) & "="
    End Select
    EncodeStr64 = sOutput & sLast
    End Function
    
Public Function DecodeStr64(sEncoded As StringAs String
    Dim sDecoded As String
    Dim d(0 To 3) As Integer
    Dim As Integer
    Dim di As Integer
    Dim As Integer
    Dim nLen As Integer
    Dim iIndex As Integer
    nLen = Len(sEncoded)
    sDecoded = ""
    iIndex = 0
    di = 0
    Call MakeDecTab
    For i = 1 To Len(sEncoded)
        C = CByte(Asc(Mid(sEncoded, i, 1)))
        C = aDecTab(C)
        If C >= 0 Then
            d(di) = C
            di = di + 1
            If di = 4 Then
                sDecoded = sDecoded & DecodeQuantum(d)
                iIndex = iIndex + 3
                If d(3) = 64 Then
                    sDecoded = Left(sDecoded, Len(sDecoded) - 1)
                    iIndex = iIndex - 1
                End If
                If d(2) = 64 Then
                    sDecoded = Left(sDecoded, Len(sDecoded) - 1)
                    iIndex = iIndex - 1
                End If
                di = 0
            End If
        End If
    Next
    DecodeStr64 = sDecoded
End Function

Private Function EncodeQuantum(b() As StringAs String
    Dim sOutput As String
    Dim As Integer
    sOutput = ""
    C = SHR2(b(0)) And &H3F
    sOutput = sOutput & Mid(sEncTab, C + 1, 1)
    C = SHL4(b(0) And &H3) Or (SHR4(b(1)) And &HF)
    sOutput = sOutput & Mid(sEncTab, C + 1, 1)
    C = SHL2(b(1) And &HF) Or (SHR6(b(2)) And &H3)
    sOutput = sOutput & Mid(sEncTab, C + 1, 1)
    C = b(2) And &H3F
    sOutput = sOutput & Mid(sEncTab, C + 1, 1)
    EncodeQuantum = sOutput
End Function

Private Function DecodeQuantum(d() As IntegerAs String
    Dim sOutput As String
    Dim As Integer
    sOutput = ""
    C = SHL2(d(0)) Or (SHR4(d(1)) And &H3)
    sOutput = sOutput & Chr(C)
    C = SHL4(d(1) And &HF) Or (SHR2(d(2)) And &HF)
    sOutput = sOutput & Chr(C)
    C = SHL6(d(2) And &H3) Or d(3)
    sOutput = sOutput & Chr(C)
    DecodeQuantum = sOutput
End Function

Private Function MakeDecTab()
    Dim As Integer
    Dim As Integer
    For C = 0 To 255
        aDecTab(C) = -1
    Next
    t = 0
    For C = Asc("A") To Asc("Z")
        aDecTab(C) = t
        t = t + 1
    Next
    For C = Asc("a") To Asc("z")
        aDecTab(C) = t
        t = t + 1
    Next
    For C = Asc("0") To Asc("9")
        aDecTab(C) = t
        t = t + 1
    Next
    C = Asc("+")
    aDecTab(C) = t
    t = t + 1
    C = Asc("/")
    aDecTab(C) = t
    t = t + 1
    C = Asc("=")
    aDecTab(C) = t
End Function

Public Function SHL2(ByVal bytValue)
    SHL2 = (bytValue * &H4) And &HFF
End Function

Public Function SHL4(ByVal bytValue)
    SHL4 = (bytValue * &H10) And &HFF
End Function

Public Function SHL6(ByVal bytValue)
    SHL6 = (bytValue * &H40) And &HFF
End Function

Public Function SHR2(ByVal bytValue)
    SHR2 = bytValue \ &H4
End Function

Public Function SHR4(ByVal bytValue)
    SHR4 = bytValue \ &H10
End Function

Public Function SHR6(ByVal bytValue)
    SHR6 = bytValue \ &H40
End Function


Gruß
Nepumuk


Bild


Betrifft: Sorry,... nicht aktualisiert :-) von: Ramses
Geschrieben am: 27.02.2005 17:47:40

Hallo Nepumuk

Wow,...aber das ist nun schon höhere Schule :-)


Gruss Rainer


Bild


Betrifft: AW: Sorry,... nicht aktualisiert :-) von: Nepumuk
Geschrieben am: 27.02.2005 17:56:57

Hallo Rainer,

da gibt's schon noch eine Steigerung z.B. "Blowfish" mit einer 128Bit Verschlüsselung.

Gruß
Nepumuk


Bild


Betrifft: AW: eigene Passworte verschluesseln von: Ramses
Geschrieben am: 27.02.2005 17:45:40

Hallo

Mal ganz einfach und billig

Sub CrypTest()
'Passwort = Muster
Dim Pw As String
Pw = "Muster"
MsgBox "Neues Passwort: " & DemoCryp(Pw)
End Sub


Sub UnCrypTest()
'Crypt Passwort von "Muster" = "T|z{ly"
Dim Pw As String
Pw = "T|z{ly"
MsgBox "Original Passwort: " & DemoUnCryp(Pw)
End Sub



Function DemoCryp(chkPW As String) As String
Dim i As Integer
Dim newPw As String
newPw = ""
For i = 1 To Len(chkPW)
    newPw = newPw & Chr(Asc(Mid(chkPW, i, 1)) + 7)
Next i
Debug.Print newPw
DemoCryp = newPw
End Function


Function DemoUnCryp(chkPW As String) As String
Dim i As Integer
Dim newPw As String
newPw = ""
For i = 1 To Len(chkPW)
    newPw = newPw & Chr(Asc(Mid(chkPW, i, 1)) - 7)
Next i
Debug.Print newPw
DemoUnCryp = newPw
End Function


Gruss Rainer


Bild


Betrifft: AW: eigene Passworte verschluesseln von: manfred
Geschrieben am: 27.02.2005 19:33:10

Vielen Dank, habs getestet, läuft prima.
DANKE
Manfred


Bild


Betrifft: AW: eigene Passworte verschluesseln von: manfred
Geschrieben am: 27.02.2005 19:33:34

Vielen Dank, habs getestet, läuft prima.
DANKE
Manfred


 Bild

Beiträge aus den Excel-Beispielen zum Thema "eigene Passworte verschluesseln"