eigene Passworte verschluesseln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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 String) As String
    Dim sOutput As String, sLast As String
    Dim b(0 To 2) As String
    Dim j As Byte
    Dim i 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 String) As String
    Dim sDecoded As String
    Dim d(0 To 3) As Integer
    Dim C As Integer
    Dim di As Integer
    Dim i 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 String) As String
    Dim sOutput As String
    Dim C 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 Integer) As String
    Dim sOutput As String
    Dim C 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 t As Integer
    Dim C 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

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

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread