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"