Krypteringsprogram

Hej

Kan du bruge dette?

Private Sub cmdKryptering_Click()
  Dim l As Integer
  Dim i As Integer
  Dim BogstavVaerdi As Integer
  Dim TempStr As String
  Dim KrypteringStr As String
  l = Len(txtOrginal.Text)
  For i = 1 To l
    TempStr = Mid(txtOrginal, i, 1)
    BogstavVaerdi = Asc(TempStr)
    BogstavVaerdi = BogstavVaerdi + Val(txtFaktor.Text)
    KrypteringStr = Chr(BogstavVaerdi)
    txtKryptering.Text = txtKryptering.Text + KrypteringStr
  Next i
End Sub

mansoor:> ikke sikker nok ;-)
Lad os bruge noget med et password .. laver lige noget

Finder lige noget!

Her:
---------------------------------

\'**************************************
\' Name: (Update) RC4 Stream Cipher (with
\'    file handling )
\' Description:This code offers you a str
\'    ong encryption with RC4. I\'ve tested it
\'    a lot and it\'s the right implementation
\'    of the RC4 cipher.
\'You can use this code in your commercia
\'    l code because it\'s not patented!
\'I know there is another code that deals


\'    with RC4 but my code has nothing to do w
    \'    ith this code!
    \'More infos: sci.crypt
\' By: Sebastian
\'
\' Inputs:Create the form and simply sele
\'    ct a file to en(de)crypt!
\'Notice that you use the same function f
\'    or encryption and decryption
\'
\' Returns:After you press the Button you
\'    should get the en(de)crypted file!
\'
\' Assumes:\'Assumes:Create a form with:
\'
\'txtpwd (txtbox)
\'txtSave (txtbox)
\'txtPattern (Combobox)
\'filList (FileListBox)
\'DirList (DirListBox)
\'drvList (DrvlistBox)
\'Command1 (Command Button ; Caption=Encr
\'    ypt)
\'Command2 (Command Button ; Caption=Decr
\'    ypt)
\'
\' Side Effects:If you encrypt different
\'    textes with the same password, someone c
\'    ould be able to decrypt your code. (This
\'    is quiet normal for a stream cipher!)
If YOU ENCRYPT LARGE FILES PLEASE USE THE EnDeCryptSingle ROUTINE INSTEAD OF THE EnDeCrypt ROUTINE OR SPLIT THE INPUT IN SMALLER PIECES!
\'
\'This code is copyrighted and has\' limited warranties.Please see http://w
\'    ww.Planet-Source-Code.com/xq/ASP/txtCode
\'    Id.1736/lngWId.1/qx/vb/scripts/ShowCode.
\'    htm\'for details.\'**************************************

Option Explicit
Dim s(0 To 255) As Integer \'S-Box
Dim kep(0 To 255) As Integer
Dim i As Integer, j As Integer
\'For the file actions
Dim path As String


Public Sub RC4ini(Pwd As String)
    Dim temp As Integer, a As Integer, b As Integer
    \'Save Password in Byte-Array
    b = 0


    For a = 0 To 255
        b = b + 1


        If b > Len(Pwd) Then
            b = 1
        End If
        kep(a) = Asc(Mid$(Pwd, b, 1))
    Next a
    \'INI S-Box


    For a = 0 To 255
        s(a) = a
    Next a
    b = 0


    For a = 0 To 255
        b = (b + s(a) + kep(a)) Mod 256
        \' Swap( S(i),S(j) )
        temp = s(a)
        s(a) = s(b)
        s(b) = temp
    Next a
End Sub
\'Only use this routine for short texts


Public Function EnDeCrypt(plaintxt As Variant) As Variant
    Dim temp As Integer, a As Long, i As Integer, j As Integer, k As Integer
    Dim cipherby As Byte, cipher As Variant


    For a = 1 To Len(plaintxt)
        i = (i + 1) Mod 256
        j = (j + s(i)) Mod 256
        \' Swap( S(i),S(j) )
        temp = s(i)
        s(i) = s(j)
        s(j) = temp
        \'Generate Keybyte k
        k = s((s(i) + s(j)) Mod 256)
        \'Plaintextbyte xor Keybyte
        cipherby = Asc(Mid$(plaintxt, a, 1)) Xor k
        cipher = cipher & Chr(cipherby)
    Next a
    EnDeCrypt = cipher
End Function
\'Use this routine for really huge files


Public Function EnDeCryptSingle(plainbyte As Byte) As Byte
    Dim temp As Integer, k As Integer
    Dim cipherby As Byte
    i = (i + 1) Mod 256
    j = (j + s(i)) Mod 256
    \' Swap( S(i),S(j) )
    temp = s(i)
    s(i) = s(j)
    s(j) = temp
    \'Generate Keybyte k
    k = s((s(i) + s(j)) Mod 256)
    \'Plaintextbyte xor Keybyte
    cipherby = plainbyte Xor k
    EnDeCryptSingle = cipherby
End Function
\'************This section handles the fi
\'    le actions*****************


Private Sub DirList_Change()
    filList.path = Dirlist.path
End Sub


Private Sub drvList_Change()
    On Error Goto DriveHandler
    Dirlist.path = drvList.Drive
    Exit Sub
    DriveHandler:
    drvList.Drive = Dirlist.path
    Exit Sub
End Sub


Private Sub filList_Click()
    txtSave.Text = filList.List(filList.ListIndex)
End Sub


Private Sub Form_Load()
    txtPatter.AddItem \"*.*\", 0
    txtPatter.AddItem \"*.txt\", 1
    filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Change()
    filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Click()
    filList.Pattern = txtPatter.Text
End Sub
\'************* Encrypten Routine *******
\'    ***********


Private Sub Command1_Click()
    Dim inbyte As Byte
    Dim z As Long
    \'Set the Set-Box Counter zero
    i = 0: j = 0
    \'Ini the S-Boxes only once for a hole fi
    \'    le


    If txtpwd.Text = \"\" Then
        MsgBox \"You need To enter a password For encrypten or decrypten\"
        Exit Sub
    Else
        RC4ini (txtpwd.Text)
    End If
    \'Disable the Mousepointer
    MousePointer = vbHourglass
    path = Dirlist.path + \"\\\" + txtSave
    Open path For Binary As 1
    Open path + \".enc\" For Binary As 2


    For z = 1 To LOF(1)
        Get #1, , inbyte
        Put #2, , EnDeCryptSingle(inbyte)
    Next z
    Close 1
    Close 2
    \'Enable the Mousepointer
    MousePointer = vbDefault
End Sub
\'*********** Decryptenroutine **********
\'    *


Private Sub Command2_Click()
    Dim inbyte As Byte
    Dim z As Long
    \'Set the Set-Box counter zero
    i = 0: j = 0
    \'Ini the S-Boxes only once for a hole fi
    \'    le


    If txtpwd.Text = \"\" Then
        MsgBox \"You need To enter a password For encrypten or decrypten\"
        Exit Sub
    Else
        RC4ini (txtpwd.Text)
    End If
    \'Disable the Mousepointer
    MousePointer = vbHourglass
    path = Dirlist.path + \"\\\" + txtSave
    Open path For Binary As 1
    path = Left$(path, Len(path) - 4)
    Open path For Binary As 2


    For z = 1 To LOF(1)
        Get #1, , inbyte
        Put #2, , EnDeCryptSingle(inbyte)
    Next
    Close 1
    Close 2
    \'Enable the Mousepointer
    MousePointer = vbDefault
End Sub


---------------------------------
Jeg bruger den selv! Den er super!

/MadD

Undskyld, men jeg skulle bruge noget jeg kunne forstå, så det fra mansoor vælger jeg, men jeg ved bare ikke hvordan jeg godkender

WOW .. det var sku da noget af en gang overkill for en smule encryption ..
Godtnok er det en god kryptering, men flg. er som også meget god ..

Function Crypt(strText As String, strPass As String) As String
    pwdIndex = 1
   
    For lngIndex = 1 To Len(strText)
        intChar = Asc(Mid(strText, lngIndex, 1))
        intCrpt = Asc(Mid(strPass, pwdIndex, 1))
       
        strCrypt = strCrypt + Chr((intChar Xor intCrpt))
       
        pwdIndex = pwdIndex + 1
        If pwdIndex > Len(strPass) Then pwdIndex = 1
    Next
   
    Crypt = strCrypt
End Function

tvbamse:> du vælger fra listen lige over skrivefeltet og trykker accepter ..

hmm .. ville du have givet mig pointene eller mansoor ?

grunden til du ikke kunne accepter mansoors \"svar\" var fordi han kun have lavet en kommentar..

Nå Tdaugaard, du fik point, ja, når jeg selv skal sige det, så er din måde bedre end min, nå men tillykke

tvbamse:> okæi .. men tak så :-)

Jeg fatter ikke en meter, går du Td

mansoor:> ehm .. ikke helt ;-)

Undskyld mansoor, da jeg lige er blevet medlem af eksperten, har jeg lidt begyndervanskeligheder med at give point, pointne  skulle have været gået til dig, men nu har TD fået dem, kan man gøre noget?

http://www.eksperten.dk/spm/43291

Skal jeg gøre noget for at få pointne ?

mansoor:> ja .. stå på tungen og syng Amazing Grace ;-) nej .. smut hen i det spm. jeg har skrevet og svar!

prøv også her: http://www.eksperten.dk/spm/35214

http://www.planet-source-code.com/xq/ASP/txtCodeId.7267/lngWId.1/qx/vb/scripts/ShowCode.htm

80- or 128-bit PC1 encryption

\"stå på tungen og syng Amazing Grace ;-) nej .. smut hen i det spm. jeg har skrevet og svar! \"

tdaugaard>>>Jeg troede at vores sexlege var hemmelige!

blazer:> *suuuk*