Encrypte/Decrypt a File

Category: Security

Date: 03-28-2012

Return to Index


 
'XOR encryption using a single character password
'Run this function to encrypt, run again to decrypt
 
'Primary Code:
'Credit: Author unknown (off the web, but I can't find where!)
Function EncryptMyString(text$, Psw$) As String
   Local i As Long, a As Long, temp$
   For i = 1 To Len(text$)
         a = i Mod Len(Psw$)
         If a = 0 Then a = Len(Psw$)
         Mid$(temp$,i) = (Chr$(Asc(Mid$(Psw$,a,1)) XOR Asc(Mid$(text$,i,1))))
   Next i
   Function = temp$
End Function
 
 
'Compilable Example:
'This code encrypts/decrypts a file.  The first time you run it, a sample
'file is created and saved - unencrypted. Press the button again and  the
'file is saved as encrypted.  Each button press reverses the last action.
 
'It does not detect whether a file has been encrypted. In my apps, when
'I encrypt a file, I add some "recognition" bytes to the front of the
'file - such as "E+$crlf" so I can check to know if I should decrypt
'the file when it is loaded.
 
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "Win32API.inc"
Global hDlg As Dword, qFreq, qStart, qStop As Quad
%IDC_Button = 100
 
Function PBMain() As Long
   Dialog New Pixels, 0, "Test Code",300,300,300,200, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, %IDC_Button,"Push", 50,10,100,20
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local i As Long, txt$, psw$
   Select Case Cb.Msg
      Case %WM_InitDialog
         CreateSampleData
      Case %WM_Command
         If Cb.Ctl = %IDC_Button And Cb.CtlMsg = %BN_Clicked Then
            Open EXE.Path$ + "myfile.txtFor Binary As #1
            Get$ #1, Lof(1), txt$
            psw$ = "please"
            '-------------------------------------------------------
            QueryPerformanceFrequency qFreq
            QueryPerformanceCounter qStart
            Encrypt_asc(txt$, Psw$)
            QueryPerformanceCounter qStop
            Dialog Set Text hDlg, Time$ + " : " + Format$((qStop-qStart)/qFreq,"###.000") & " seconds"
            '-------------------------------------------------------
            Seek #1,1 : Put$ #1, txt$ : Close #1
         End If
   End Select
End Function
 
Sub CreateSampleData   'run this to create a sample file
   Local i As Long
   Open EXE.Path$ + "myfile.txtFor Output As #1
   Print #1, "Beginning of Sample Text"
   For i = 1 To 100000
      Print #1, "aadsfadfasdseasjlkpoiupoiupoiu"  '3M characters
   Next i
   Print #1, "End of Sample Text"
   Close #1
End Sub
 
Function Encrypt_Mid(text$, Psw$) As String    'Beene
   Local i,a As Long, temp$
   temp$ = text$
   For i = 1 To Len(text$)
      a = (i Mod Len(Psw$)) + 1        'Joseph Cote
      Mid$(temp$,i) = (Chr$(Asc(Mid$(Psw$,a,1)) Xor Asc(Mid$(text$,i,1))))
   Next i
   Function = temp$
End Function
 
Function Encrypt_ASC(text$, Psw$) As String    'Hanlin
   Local i,a As Long, temp$
   temp$ = text$
   For i = 1 To Len(text$)
      a = (i Mod Len(Psw$)) + 1        'Joseph Cote
      Asc(temp$,i) = Asc(psw$,a) Xor Asc(temp$,i)
   Next i
   Function = temp$
End Function
 
Function Encrypt_Overlay(text$, Psw$) As String    'John Gleason
   Local i,a As Long, temp$, c$, result$
   temp$ = text$
   Dim textArr(1 To Len(text$)) As Byte At StrPtr(text$) 'These are the 3 key lines. Now you can access each byte to
   Dim tempArr(1 To Len(temp))  As Byte At StrPtr(temp)  'encode by using array subscripts directly. No pointers
   Dim  pswArr(1 To Len( psw$)) As Byte At StrPtr(psw$)  'are necessary and it's approx. equal in speed to pointers.
   For i = 1 To Len(text$)
      a = (i Mod Len(Psw$)) + 1        'Joseph Cote
      tempArr(i) = textArr(i) Xor pswArr(a)
   Next i
   Function = temp$
End Function
 
Function Encrypt_PTRA(txt$, psw$) As Long  'Wayne Diamond
   Local i,kEnd,StrPtrrPW As Long, tPtr, kPtr As Byte Ptr
   tPtr = StrPtr(txt$)
   kPtr = StrPtr(psw$)
   kEnd = kPtr + Len(psw$)
   StrPtrrPW = kPtr
   For i = 1 To Len(txt$)
      @tPtr = @tPtr Xor @kPtr
      Incr tPtr
      If kPtr = kEnd Then kPtr = StrPtrrPW Else Incr kPtr
   Next i
End Function
 
Function Encrypt_PTR_Indx(txt$, psw$) As Long    'Ross Boyd
   Local i,j,kEnd As Long, tPtr, kPtr As Byte Ptr
   tPtr = StrPtr(txt$)
   kPtr = StrPtr(psw$)
   kEnd = Len(psw$) - 1
   For i = 0 To Len(txt$) - 1
      @tPtr[i] Xor = @kPtr[j]
      If j = kEnd Then j = 0 Else Incr j
   Next i
End Function
 
Function Encrypt_PEEK(Txt$, psw$) As Long     'Paul Dixon
   Register tPtr As Long, kPtr As Long
   Local i, kEnd, StrPtrrPW As Long
   tPtr = StrPtr(Txt$)
   kPtr = StrPtr(psw$)
   StrPtrrPW = kPtr
   kEnd = kPtr + Len(psw$)
   For i = 1 To Len(Txt$)
      Poke Byte, tPtr,Peek(Byte,tPtr) Xor Peek(Byte,kPtr)
      Incr tPtr
      If kPtr = kEnd Then kPtr = StrPtrrPW Else Incr kPtr
   Next i
End Function
 
Function Encrypt_ASM(Txt$, psw$) As Long      'Paul Dixon
   Register dummy1 As Long       'make sure the registers aren't used
   Register dummy2 As Long
 
   Local i,tPtr,kPtr,kEnd,LenTxt As Long
   tPtr = StrPtr(Txt$)
   kPtr = StrPtr(psw$)
   kEnd = kPtr + Len(psw$)
   LenTxt=Len(Txt$)
 
   !mov esi,tPtr            'get pointers to the strings into registers
   !mov edi,kPtr
   !mov edx,LenTxt
 
   'FOR i = 1 TO LEN(TXT$)
   !mov ecx,1               'i = 1
   #Align 16
lp:
   !mov al,[edi]            'get password character
   !xor [esi],al            'xor string character with it
 
   !inc esi                 'increment the 2 pointers
   !inc edi
 
   !cmp edi,kEnd            'if password pointer is too big then ..
   !cmove edi,kPtr          '.. reload it
 
   !inc ecx                 'NEXT i
   !cmp ecx,edx             'i = LENtxt?
   !jle short lp            'no, loop back
 
End Function
 
'gbs_00234
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm