Private Const MAX_PWD_LEN = 16 Public Function EncodePassword(ByVal strSeedName As String, ByVal strPwd As String) As String Dim bytArySeed() As Byte Dim bytAryPwd() As Byte bytArySeed = GetSeedArray(strSeedName) bytAryPwd = GetPwdArray(strPwd) EncodePassword = AddSeedToPwd(bytAryPwd, bytArySeed) Erase bytArySeed Erase bytAryPwd End Function Public Function DecodePassword(ByVal strSeedName As String, ByVal strPwd As String) As String Dim bytArySeed() As Byte Dim bytAryPwd() As Byte bytArySeed = GetSeedArray(strSeedName) bytAryPwd = GetEncPwdArray(strPwd) DecodePassword = RemoveSeedFromPwd(bytAryPwd, bytArySeed) Erase bytArySeed Erase bytAryPwd End Function Private Function GetSeedArray(ByVal strSeedName As String) As Byte() Dim i As Integer Dim nIndex As Integer Dim bytAry() As Byte Dim bytAryRet(MAX_PWD_LEN - 1) As Byte strSeedName = VBA.UCase$(strSeedName) bytAry = VBA.StrConv(strSeedName, vbFromUnicode) For i = 0 To UBound(bytAry) nIndex = nIndex + bytAry(i) + ((i + 1) * 2) Next i Call Rnd(-1) 'reset Randomize nIndex For i = 0 To (MAX_PWD_LEN - 1) bytAryRet(i) = ((VBA.CLng(Rnd(nIndex) * (10 ^ 6))) Mod 256) Next i 'geri döndür GetSeedArray = bytAryRet 'array'i alanlarini sil Erase bytAry Erase bytAryRet End Function Private Function GetPwdArray(ByVal strPwd As String) As Byte() Dim i As Integer Dim nCnt As Integer Dim nIndex As Integer Dim bytAry() As Byte Dim bytAryRet(MAX_PWD_LEN - 1) As Byte strPwd = VBA.Left$(strPwd, MAX_PWD_LEN) bytAry = VBA.StrConv(strPwd, vbFromUnicode) nCnt = UBound(bytAry) + 1 For i = 0 To (MAX_PWD_LEN - 1) If i < nCnt Then bytAryRet(i) = bytAry(i) ElseIf i > nCnt Then bytAryRet(i) = ((VBA.CLng(Rnd() * (10 ^ 6))) Mod 256) End If Next i 'geri döndür GetPwdArray = bytAryRet 'array'i alanlarini sil Erase bytAry Erase bytAryRet End Function Private Function GetEncPwdArray(ByVal strPwd As String) As Byte() Dim bytAryRet(MAX_PWD_LEN - 1) As Byte Dim nCnt As Integer Dim i As Integer nCnt = VBA.Len(strPwd) If nCnt = (2 * MAX_PWD_LEN) Then For i = 0 To (MAX_PWD_LEN - 1) bytAryRet(i) = VBA.CByte("&H" & VBA.Mid$(strPwd, (2 * i) + 1, 2)) Next i End If GetEncPwdArray = bytAryRet End Function Private Function AddSeedToPwd(bytAryPwd() As Byte, bytArySeed() As Byte) As String Dim i As Integer Dim nChar As Integer Dim sRet As String Dim nCount As Integer For i = 0 To (MAX_PWD_LEN - 1) nChar = ((VBA.CLng(bytAryPwd(i)) + bytArySeed(i)) Mod 256) sRet = sRet & VBA.IIf((nChar < 16), "0", "") & VBA.Hex(nChar) Next i AddSeedToPwd = sRet End Function Private Function RemoveSeedFromPwd(bytAryPwd() As Byte, bytArySeed() As Byte) As String Dim i As Integer Dim nChar As Integer Dim sRet As String For i = 0 To (MAX_PWD_LEN - 1) nChar = VBA.CInt(bytAryPwd(i)) - bytArySeed(i) If nChar = 0 Then Exit For If nChar < 0 Then nChar = 256 + nChar sRet = sRet & VBA.Chr$(nChar) Next i RemoveSeedFromPwd = sRet End Function '//******************************************// 'Kullanimi; Dim strPwd As String '1234 sifresini, farkli bir dizilime dönüstürüyoruz. strPwd = EncodePassword("merhaba", "1234") 'yukaridaki islem sonucunda 'strPwd degeri 'E4B9C17E8B5987199A6174AC74B3FA3F' olacaktir. (Kodda bir degisiklik yapmadiysaniz) 'daha sonra 'E4B9C17E8B5987199A6174AC74B3FA3F' degerini 'DecodePassword fonksiyonuna gönderip çözecegiz. strPwd = DecodePassword("merhaba", strPwd) 'bu islem neticesinde strPwd degeri tekrar '1234' olacaktir. 'merhaba' olarak belirtilen SeedName bölümünü degistirerek ilgili password'u farkli dizilimlerde saklayabilirsiniz.
