Avatar billede h7iws Nybegynder
23. maj 2007 - 22:36 Der er 3 kommentarer og
1 løsning

Simpel kryptering, lille kode

Skal bruge en simpel kryptering til data-all-round, noget a la Xor etc.
Det skal kodemæssigt ikke fylde så meget og stadig være rimelig ubrydeligt, så alm. bruger til alm. nørdt ikke kan bryde det ...

Evt. gerne noget der kan kodes med to password's af varierende længde ...

Nogen der har sådan en på lager ??

/h7iws
Avatar billede sjh Nybegynder
23. maj 2007 - 22:45 #1
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.. ;)
Avatar billede h7iws Nybegynder
25. maj 2007 - 19:40 #2
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 ...
Avatar billede sjh Nybegynder
25. maj 2007 - 20:20 #3
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 ----------------------------
Avatar billede h7iws Nybegynder
08. august 2007 - 07:04 #4
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
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Kurser inden for grundlæggende programmering

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester