vurdering af encryptering
hejsa, uuh, det er godt nok længe siden jeg har stillet et spm herinde.. det er helt rart at være tilbage.. hehe..anyway, idag lavede jeg et encrypterings program i vb.. jeg ville egentlig bare have en vurdering af programmet, hvorvidt den encrypterede text er sikker..
programmet er primært til at encryptere emails eller beskedder med..
koden er nok lidt sjusket, da det gik lidt stærkt ;)..
programmet bruger md5 algoritmen til at encryptere med..
jeg dl den her:
http://www.di-mgt.com.au/src/di_md5dll.zip
enc_md5.frm ------------------------------
Private Declare Function MakeMD5Digest Lib "di_MD5DLL.dll" (ByVal sData As String, ByVal sDigest As String) As Long
Public Function hex2chr(strHex As String) As String
Dim strChr As String, i As Long
For i = 1 To Len(strHex$) Step 2
strChr$ = strChr$ & Chr$(Val("&H" & Mid$(strHex$, i, 2)))
Next i
hex2chr$ = strChr$
End Function
Public Function chr2hex(strChr As String) As String
Dim strHex As String, i As Long
For i = 1 To Len(strChr$)
strHex$ = strHex$ & LCase$(lz$(Hex(Asc(Mid$(strChr$, i, 1))), 2))
Next i
chr2hex$ = strHex$
End Function
Public Function lz(strInput As String, l As Long) As String
If Len(strInput$) < l Then
Do Until Len(strInput$) = l
strInput$ = "0" & strInput$
Loop
End If
lz$ = strInput$
End Function
Public Function md5_hex(sData As String, l As Long) As String
Dim i As Long
sData$ = MD5HexDigest$(sData$)
For i = 1 To Int(l / 16 + 0.9)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
sData$ = MD5HexDigest$(sData$)
Next i
md5_hex$ = sData$
End Function
Public Function md5_dbl(sData As String) As Double
Dim dOut As Double
sData$ = md5_hex$(sData$, 1024)
dOut = Val("&H" & Mid$(sData$, 1, 16))
dOut = dOut + Val("&H" & Mid$(sData$, 17))
md5_dbl = rndPrime(dOut)
End Function
Public Function MD5HexDigest(sData As String) As String
Dim iRet As Long
Dim sDigest As String
' Set sDigest to be 32 chars
sDigest = String(32, " ")
iRet = MakeMD5Digest(sData, sDigest)
MD5HexDigest = Trim(sDigest)
End Function
Public Function rndPrime(dblSeed As Double) As Double
Dim i As Long, prime As Double, _
check1 As Double, check2 As Double
Call Rnd(-1)
Randomize dblSeed
Restart:
prime = 10000000000# + Int(Rnd * 89999999999#)
For i = 2 To Sqr(prime)
check1 = prime / i
check2 = Int(check1)
If check1 = check2 Then
GoTo Restart
End If
Next i
rndPrime = prime
End Function
Public Function enc(strPlaintext As String, strPassword As String) As String
Dim strCiphertext As String, arrC() As String, i As Long, _
tmp As String, tmp1 As Double, a As String, b As String, _
c1 As String, tmp2 As String, l As Long, tmpa As Double
ReDim arrC(255) As String
Form1.Caption = "preparing.."
tmp2$ = strPlaintext$
Randomize
Randomize (rndPrime(Rnd * 10000000)) + (rndPrime(md5_dbl(tmp2$)))
strPlaintext$ = strPlaintext$ & Chr(17) & Chr(11) & Chr(7) & Chr(15)
Do Until Len(strPlaintext$) Mod 64 = 0
strPlaintext$ = strPlaintext$ & Chr$(Int(Rnd * 255) + 1)
DoEvents
Loop
a$ = md5_hex$(strPassword$, 256)
tmp$ = a$
tmpa = md5_dbl(tmp$)
tmp$ = a$
tmp2$ = strPlaintext$
Randomize
Randomize (rndPrime(Rnd * 10000000)) + (rndPrime(md5_dbl(tmp$))) + (rndPrime(md5_dbl(tmp2$)))
b$ = "": i = 0
Do Until Len(b$) >= 32
b$ = b$ & LCase$(Hex(Rnd * 16))
Loop
DoEvents
tmp$ = b$
i = 0
For i = 0 To 255
arrC$(i) = a$ & Hex(i) & tmp$
Next i
i = 0
For i = 1 To Len(strPlaintext$)
tmp$ = Mid$(strPlaintext$, i, 1)
strCiphertext$ = strCiphertext$ & getI$(MD5HexDigest$(arrC$(Asc(tmp$)) & CStr(i)))
Form1.Caption = lz$(Int(i / Len(strPlaintext$) * 100), 3) & " %"
DoEvents
Next i
strCiphertext$ = EncodeStr64$(hex2chr$(b$ & strCiphertext$))
enc$ = nl$(scramble$(strCiphertext$, tmpa), 64)
Form1.Caption = "done !"
End Function
Public Function dec(strCiphertext As String, strPassword As String) As String
Dim strPlaintext As String, arrC() As String, i As Long, _
tmp As String, tmp1 As Double, x As Long, z As Long, _
a As String, b As String, tmp2 As String, tmpa As Double
ReDim arrC(255) As String
Form1.Caption = "preparing.."
a$ = md5_hex$(strPassword$, 256)
tmp$ = a$
tmpa = md5_dbl(tmp$)
strCiphertext$ = chr2hex$(DecodeStr64$(scramble$(Replace$(strCiphertext$, vbCrLf$, ""), tmpa)))
b$ = Mid$(strCiphertext$, 1, 32)
strCiphertext$ = Mid$(strCiphertext$, 33)
i = 0
For i = 0 To 255
arrC$(i) = a$ & Hex(i) & b$
Next i
z = 0: i = 0
For i = 1 To Len(strCiphertext$) Step 8
z = z + 1
tmp$ = Mid$(strCiphertext$, i, 8)
x = 0
For x = 0 To 255
If tmp$ = getI$(MD5HexDigest$(arrC$(x) & CStr(z))) Then
strPlaintext$ = strPlaintext$ & Chr$(x)
End If
Next x
Form1.Caption = lz$(Int(i / Len(strCiphertext$) * 100), 3) & " %"
DoEvents
Next i
tmp1 = InStr(strPlaintext$, Chr(17) & Chr(11) & Chr(7) & Chr(15))
If tmp1 > 0 Then
strPlaintext$ = Left$(strPlaintext$, tmp1 - 1)
End If
Form1.Caption = "done !"
dec$ = strPlaintext$
End Function
Public Function getI(sData As String) As String
Dim sOutput As String
sOutput$ = ""
'sOutput$ = Mid$(sData$, 1, 1)
sOutput$ = sOutput$ & Mid$(sData$, 3, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 5, 1)
sOutput$ = sOutput$ & Mid$(sData$, 7, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 9, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 11, 1)
sOutput$ = sOutput$ & Mid$(sData$, 13, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 15, 1)
sOutput$ = sOutput$ & Mid$(sData$, 17, 1)
sOutput$ = sOutput$ & Mid$(sData$, 19, 1)
sOutput$ = sOutput$ & Mid$(sData$, 21, 1)
sOutput$ = sOutput$ & Mid$(sData$, 23, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 25, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 27, 1)
sOutput$ = sOutput$ & Mid$(sData$, 29, 1)
'sOutput$ = sOutput$ & Mid$(sData$, 31, 1)
getI$ = sOutput$
End Function
Public Function nl(sInput As String, l As Long) As String
Dim i As Long, sOutput As String
For i = 1 To Len(sInput$)
If i Mod l = 0 Then
sOutput$ = sOutput$ & Mid$(sInput$, i, 1) & vbCrLf$
Else
sOutput$ = sOutput$ & Mid$(sInput$, i, 1)
End If
Next i
nl$ = sOutput$
End Function
Function scramble(sData As String, dSeed As Double) As String
Dim arrS() As Byte, l As Long, sOutput As String, i As Long, _
x As Long, y As Long, strU As String, tmp As Byte
l = Len(sData$)
ReDim arrS(l) As Byte
i = 0
For i = 1 To l
arrS(i - 1) = Asc(Mid$(sData$, i, 1))
Next i
Call Rnd(-1)
Randomize dSeed
i = 0: strU$ = ""
For i = 1 To l
x = Int(Rnd * l)
y = Int(Rnd * l)
If InStr(strU$, CStr(x)) < 1 And InStr(strU$, CStr(y)) < 1 Then
tmp = arrS(x)
arrS(x) = arrS(y)
arrS(y) = tmp
strU$ = strU$ & CStr(x) & "," & CStr(y) & ","
End If
If i Mod 512 = 0 Then
Form1.Caption = lz(Int(i / l * 100), 3) & " %"
DoEvents
End If
Next i
i = 0
For i = 0 To l - 1
sOutput$ = sOutput$ & Chr$(arrS(i))
Next i
scramble$ = sOutput$
End Function
Private Sub Command1_Click()
If Len(txtP.Text$) > 0 And Len(txtD.Text$) > 0 Then
txtE.Text$ = enc$(txtD.Text$, txtP.Text$)
ElseIf Len(txtP.Text$) > 0 And Len(txtD.Text$) = 0 Then
txtE.Text$ = enc$("emptystringthatiusewhenthereisnottexttoencrypt", txtP.Text$)
ElseIf Len(txtP.Text$) = 0 And Len(txtD.Text$) > 0 Then
txtE.Text$ = enc$(txtD.Text$, "tpyrcneottxettonsierehtnehwesuitahtgnirtsytpme")
ElseIf Len(txtP.Text$) = 0 And Len(txtD.Text$) = 0 Then
txtE.Text$ = enc$("emptystringthatiusewhenthereisnottexttoencrypt", "tpyrcneottxettonsierehtnehwesuitahtgnirtsytpme")
End If
End Sub
Private Sub Command2_Click()
If Len(txtP.Text$) > 0 And Len(txtE.Text$) > 0 Then
txtD.Text$ = dec$(txtE.Text$, txtP.Text$)
End If
End Sub
base64.bas -------------------------------
Option Explicit
Option Base 0
Private aDecTab(255) As Integer
Private aEncTab(63) As Byte
Public Function EncodeStr64(sInput As String) As String
' Return radix64 encoding of string of binary values
' Does not insert CRLFs. Just returns one long string,
' so it's up to the user to add line breaks or other formatting.
' Version 4: Use Byte array and StrConv - much faster
Dim abOutput() As Byte ' Version 4: now a Byte array
Dim sLast As String
Dim b(3) As Byte ' Version 4: Now 3 not 2
Dim j As Integer
Dim i As Long, nLen As Long, nQuants As Long
Dim iIndex As Long
EncodeStr64 = ""
nLen = Len(sInput)
nQuants = nLen \ 3
iIndex = 0
Call MakeEncTab
If (nQuants > 0) Then
ReDim abOutput(nQuants * 4 - 1)
' Now start reading in 3 bytes at a time
For i = 0 To nQuants - 1
For j = 0 To 2
b(j) = Asc(Mid(sInput, (i * 3) + j + 1, 1))
Next
Call EncodeQuantumB(b)
abOutput(iIndex) = b(0)
abOutput(iIndex + 1) = b(1)
abOutput(iIndex + 2) = b(2)
abOutput(iIndex + 3) = b(3)
iIndex = iIndex + 4
Next
EncodeStr64 = StrConv(abOutput, vbUnicode)
End If
' Cope with odd bytes
' (no real performance hit by using strings here)
Select Case nLen Mod 3
Case 0
sLast = ""
Case 1
b(0) = Asc(Mid(sInput, nLen, 1))
b(1) = 0
b(2) = 0
Call EncodeQuantumB(b)
sLast = StrConv(b(), vbUnicode)
' Replace last 2 with =
sLast = Left(sLast, 2) & "=="
Case 2
b(0) = Asc(Mid(sInput, nLen - 1, 1))
b(1) = Asc(Mid(sInput, nLen, 1))
b(2) = 0
Call EncodeQuantumB(b)
sLast = StrConv(b(), vbUnicode)
' Replace last with =
sLast = Left(sLast, 3) & "="
End Select
EncodeStr64 = EncodeStr64 & sLast
End Function
Public Function DecodeStr64(sEncoded As String) As String
' Return string of decoded binary values given radix64 string
' Ignores any chars not in the 64-char subset
' Version 4: Use Byte array and StrConv - much faster
Dim abDecoded() As Byte 'Version 4: Now a Byte array
Dim d(3) As Byte
Dim C As Integer ' NB Integer to catch -1 value
Dim di As Integer
Dim i As Long
Dim nLen As Long
Dim iIndex As Long
nLen = Len(sEncoded)
If nLen < 4 Then
Exit Function
End If
ReDim abDecoded(((nLen \ 4) * 3) - 1) 'Version 4: Now base zero
iIndex = 0 ' Version 4: Changed to base 0
di = 0
Call MakeDecTab
' Read in each char in turn
For i = 1 To Len(sEncoded)
C = CByte(Asc(Mid(sEncoded, i, 1)))
C = aDecTab(C)
If C >= 0 Then
d(di) = CByte(C) ' Version 3.1: add CByte()
di = di + 1
If di = 4 Then
abDecoded(iIndex) = SHL2(d(0)) Or (SHR4(d(1)) And &H3)
iIndex = iIndex + 1
abDecoded(iIndex) = SHL4(d(1) And &HF) Or (SHR2(d(2)) And &HF)
iIndex = iIndex + 1
abDecoded(iIndex) = SHL6(d(2) And &H3) Or d(3)
iIndex = iIndex + 1
If d(3) = 64 Then
iIndex = iIndex - 1
abDecoded(iIndex) = 0
End If
If d(2) = 64 Then
iIndex = iIndex - 1
abDecoded(iIndex) = 0
End If
di = 0
End If
End If
Next i
' Convert to a string
DecodeStr64 = StrConv(abDecoded(), vbUnicode)
' Remove any unwanted trailing chars
DecodeStr64 = Left(DecodeStr64, iIndex)
End Function
Private Sub EncodeQuantumB(b() As Byte)
' Expects at least 4 bytes in b, i.e. Dim b(3) As Byte
Dim b0 As Byte, b1 As Byte, b2 As Byte, b3 As Byte
b0 = SHR2(b(0)) And &H3F
b1 = SHL4(b(0) And &H3) Or (SHR4(b(1)) And &HF)
b2 = SHL2(b(1) And &HF) Or (SHR6(b(2)) And &H3)
b3 = b(2) And &H3F
b(0) = aEncTab(b0)
b(1) = aEncTab(b1)
b(2) = aEncTab(b2)
b(3) = aEncTab(b3)
End Sub
Private Function MakeDecTab()
' Set up Radix 64 decoding table
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("=") ' flag for the byte-deleting char
aDecTab(C) = t ' should be 64
End Function
Private Function MakeEncTab()
' Set up Radix 64 encoding table in bytes
Dim i As Integer
Dim C As Integer
i = 0
For C = Asc("A") To Asc("Z")
aEncTab(i) = C
i = i + 1
Next
For C = Asc("a") To Asc("z")
aEncTab(i) = C
i = i + 1
Next
For C = Asc("0") To Asc("9")
aEncTab(i) = C
i = i + 1
Next
C = Asc("+")
aEncTab(i) = C
i = i + 1
C = Asc("/")
aEncTab(i) = C
i = i + 1
End Function
' Version 3: ShiftLeft and ShiftRight functions improved.
Private Function SHL2(ByVal bytValue As Byte) As Byte
' Shift 8-bit value to left by 2 bits
' i.e. VB equivalent of "bytValue << 2" in C
SHL2 = (bytValue * &H4) And &HFF
End Function
Private Function SHL4(ByVal bytValue As Byte) As Byte
' Shift 8-bit value to left by 4 bits
' i.e. VB equivalent of "bytValue << 4" in C
SHL4 = (bytValue * &H10) And &HFF
End Function
Private Function SHL6(ByVal bytValue As Byte) As Byte
' Shift 8-bit value to left by 6 bits
' i.e. VB equivalent of "bytValue << 6" in C
SHL6 = (bytValue * &H40) And &HFF
End Function
Private Function SHR2(ByVal bytValue As Byte) As Byte
' Shift 8-bit value to right by 2 bits
' i.e. VB equivalent of "bytValue >> 2" in C
SHR2 = bytValue \ &H4
End Function
Private Function SHR4(ByVal bytValue As Byte) As Byte
' Shift 8-bit value to right by 4 bits
' i.e. VB equivalent of "bytValue >> 4" in C
SHR4 = bytValue \ &H10
End Function
Private Function SHR6(ByVal bytValue As Byte) As Byte
' Shift 8-bit value to right by 6 bits
' i.e. VB equivalent of "bytValue >> 6" in C
SHR6 = bytValue \ &H40
End Function
