Simpel kryptering, lille kode

Ja det kan vi nok klare.. men måske du lige skulle give ledt feedback her : http://www.eksperten.dk/spm/775650 før du kaster dig over noget nyt.. ;)

Undskyld, det er jeg meget ked af, havde fået det til at virke, men havde helt glemt at give respons ... men mange tak for hjælpen sjh, du er meget godt inde i vb, og du er en kanon hjælp til os der er mindre befærdet på området ...

Men jeg må tilstå at det er lidt pinligt fra min side af ... endnu en gang undskyld ...

Ja ja.. ;)

Jeg bruger selv en RC4 den er god nok til det meste..

' ------------------------- RC4Lib.cls -------------------------
Option Explicit

Public Function RC4(strData As String, strPassword As String) As String
Dim arrBox(0 To 255) As Integer
Dim x As Long
Dim y As Long
Dim z As Long
Dim arrKey() As Byte
Dim arrOut() As Byte
Dim strTmp As Byte

  If Len(strPassword) = 0 Then
    Exit Function
  End If

  If Len(strData) = 0 Then
    Exit Function
  End If

  If Len(strPassword) > 256 Then
    arrKey() = StrConv(Left$(strPassword, 256), vbFromUnicode)
      Else
    arrKey() = StrConv(strPassword, vbFromUnicode)
  End If

  For x = 0 To 255
    arrBox(x) = x
  Next

  x = 0: y = 0: z = 0

  For x = 0 To 255
    y = (y + arrBox(x) + arrKey(x Mod Len(strPassword))) Mod 256
    strTmp = arrBox(x)
    arrBox(x) = arrBox(y)
    arrBox(y) = strTmp
  Next

  x = 0: y = 0: z = 0

  arrOut() = StrConv(strData, vbFromUnicode)

  For x = 0 To UBound(arrOut)
    y = (y + 1) Mod 256
    z = (z + arrBox(y)) Mod 256
    strTmp = arrBox(y)
    arrBox(y) = arrBox(z)
    arrBox(z) = strTmp
    arrOut(x) = arrOut(x) Xor (arrBox((arrBox(y) + arrBox(z)) Mod 256))
  Next

  RC4 = StrConv(arrOut, vbUnicode)
End Function

Public Function StrToHex(ByVal strData As String) As String
Dim strOut As String
  Do Until Len(strData) = 0
    strOut = strOut & Right$("00" & Hex$(Asc(Left$(strData, 1))), 2)
    strData = Right$(strData, Len(strData) - 1)
  Loop
  StrToHex = LCase$(strOut)
End Function

Public Function HexToStr(ByVal strData As String) As String
Dim strOut As String
  If (Len(strData) Mod 2) = 0 Then
    Do Until Len(strData) < 2
      strOut = strOut & Chr$(CLng("&H" & Left$(strData, 2)))
      strData = Right$(strData, Len(strData) - 2)
    Loop
  End If
  HexToStr = strOut
End Function

Public Function RC4StrToHex(strData As String, strPassword As String) As String
Dim strRC4 As String
  strRC4 = RC4(strData, strPassword)
  RC4StrToHex = StrToHex(strRC4)
End Function

Public Function RC4HexToStr(strData As String, strPassword As String) As String
Dim strRC4 As String
  strRC4 = HexToStr(strData)
  RC4HexToStr = RC4(strRC4, strPassword)
End Function
' ------------------------- RC4Lib.cls -------------------------


' --------------------------- Form1 ----------------------------
' Her en lille test.
' --------------------------------------------------------------
Option Explicit

Private objRC4 As New RC4Lib

Private Sub Form_Load()
Dim strHex As String
Dim strBin As String

  With objRC4

      ' Den her vil retuner det som er krypteret (en til en) tilstand
      strBin = .RC4("Test bin data", "password")
      MsgBox "Bin: " & strBin

      ' Udpakker
      strBin = .RC4(strBin, "password")
      MsgBox "Bin: " & strBin

      ' Den her vil retuner det som er krypteret i form af Hex, så er
      ' det nemt at copy/paste gennem tekst form. (Det vil dog også fylde det dobbelte)
      strHex = .RC4StrToHex("Test tekst pakket ind i hex!", "password")
      MsgBox "Hex: " & strHex

      ' Udpakker
      strHex = .RC4HexToStr(strHex, "password")
      MsgBox "Hex: " & strHex

  End With
End Sub
' --------------------------- Form1 ----------------------------

Takker mange gange for hjælpen.
Jeg har dog imidlertid skrevet en omgang kode selv, noget Xor-kryptering, som godt nok ikke er så stærk, medmindre man bruger flere password's af varierende længde.
Vælger at bruge min nu da jeg har skrevet den, men du skal da have pointsne for den hjælpende hånd;)
Endnu engang er Sjh på pletten :p

Min kode, hvis nogen skulle være interesseret:

Function str_xor_handle(str1 As String, str2 As String) As String '** Either string can be psswrd/data   
    Dim result As String, i As Integer, _
        sgn1 As String, sgn2 As String, _
        val1 As Long, val2 As Long, _
        bin1 As String, bin2 As String, _
        binres As String, decres As Long
       
    If Len(str1) > Len(str2) Then
   
        For i = 1 To Len(str1)
           
            sgn1 = Mid(str1, i, 1)
            sgn2 = Mid(str2, ((i - 1) Mod Len(str2)) + 1, 1) '** ( (x - 1) % y) + 1 ** er testet og burde virke 112%
           
            val1 = Asc(sgn1)
            val2 = Asc(sgn2)
           
            bin1 = dec_to_bin(val1)
            bin2 = dec_to_bin(val2)
           
            binres = bin_xor(bin1, bin2)
           
            decres = bin_to_dec(binres)
           
            result = result & Chr(decres)

        Next
         
    Else
   
        For i = 1 To Len(str2)
           
            sgn1 = Mid(str1, ((i - 1) Mod Len(str1)) + 1, 1) '** ( (x - 1) % y) + 1 ** er testet og burde virke 112%
            sgn2 = Mid(str2, i, 1)
                       
            val1 = Asc(sgn1)
            val2 = Asc(sgn2)
           
            bin1 = dec_to_bin(val1)
            bin2 = dec_to_bin(val2)
           
            binres = bin_xor(bin1, bin2)
           
            decres = bin_to_dec(binres)
           
            result = result & Chr(decres)

        Next
       
    End If
   
    str_xor_handle = result
   
End Function

Function dec_to_bin(data As Long) As String
   
    If data > 255 Or data < 0 Then '** Her er der sket en fejl...
   
    Dim i As Integer, res As String
    If data > 0 Then
        For i = (Int(Log(data) / Log(2))) To 0 Step -1
            If data >= (2 ^ i) Then data = data - (2 ^ i): res = res & "1" Else res = res & "0"
        Next
    Else
        res = "00000000" '** real 8bin
    End If

    If Len(res) < 8 Then res = String(8 - Len(res), "0") & res '** skal opfylde 8bin
   
    If Len(res) > 8 Then GoTo This_Error '** hvis den er længere end 8bin == fejl !! '** igen en fejl
   
    dec_to_bin = res

End Function

Function bin_to_dec(data As String) As Long
   
    Dim i As Integer
    Dim is_bin As Boolean
    is_bin = True
    For i = 1 To Len(data)
        If Mid(data, i, 1) <> "1" And Mid(data, i, 1) <> "0" Then is_bin = False: Exit For
    Next '** her checkes om strengen er en fuldendt bin-streng (kontrollerer om den kun indeholder 0'er og 1'taller ...)
   
    If is_bin And Len(data) = 8 Then '** is_bin er en BOOL-var + kontrol af at længden er EQU 8!
        Dim result As Long
        result = 0
        For i = Len(data) To 1 Step -1
            result = result + ((2 ^ (Len(data) - i)) * IIf(Mid(data, i, 1) = "1", 1, 0))
        Next
        bin_to_dec = result
    Else
    '** Her er der sket en fejl :s
    End If

End Function

Function bin_xor(binStr1 As String, binStr2 As String) As String

    If Len(binStr1) > 8 Or Len(binStr2) > 8 Then
        save_stat_has_failed = True
        Call HandleError("bin_xor", binStr1 & "<>" & binStr2)
        Exit Function
    End If
   
    If Len(binStr1) < 8 Then binStr1 = String(8 - Len(binStr1), "0") & binStr1 '** correcting lenght of binStr1 to 8 bin
    If Len(binStr2) < 8 Then binStr2 = String(8 - Len(binStr2), "0") & binStr2 '** correcting lenght of binStr2 to 8 bin
   
    Dim xor_res As String
    Dim i
    For i = 1 To 8 '** the lenght should only be 8 bin.
        If Mid(binStr1, i, 1) = Mid(binStr2, i, 1) Then xor_res = xor_res & "0" '** Alike EQU 0
        If Mid(binStr1, i, 1) <> Mid(binStr2, i, 1) Then xor_res = xor_res & "1" '** Different EQU 1
    Next
   
    bin_xor = xor_res
   
End Function