home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / myHMS_Data2054903202007.psc / Class / clsBinaryEncryptor.cls next >
Text File  |  2007-03-19  |  4KB  |  192 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsBinaryEncryptor"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '* Developed by Cahaltech
  15. Option Explicit
  16.  
  17. Private Declare Function GetTempPath Lib "kernel32" _
  18.         Alias "GetTempPathA" ( _
  19.         ByVal nBufferLength As Long, _
  20.         ByVal lpBuffer As String) As Long
  21.  
  22. Public Function DecryptFile(Source As String, Password As String) As String
  23.  
  24. On Error GoTo 1
  25.   Dim ByteIn() As Byte
  26.   Dim ByteOut() As Byte
  27.   Dim i As Long
  28.   Dim j As Long
  29.   Dim PL As Integer
  30.   Dim ChrBNow As Integer
  31.   Dim PosNow As Integer
  32.   Dim TempDByte As Integer
  33.   Dim ByteFinal As Integer
  34.   Dim FleeFile  As Integer
  35.   Dim Bit() As Byte
  36.  
  37.     ByteIn() = ReadBinaryArray(Source)
  38.     Bit() = ReadBinaryArray(Source)
  39.  
  40.     ReDim ByteOut(LBound(ByteIn) To UBound(ByteIn)) As Byte
  41.  
  42.     PL = Len(Password)
  43.  
  44.     For i = LBound(ByteIn) To UBound(ByteIn)
  45.  
  46.         PosNow = i Mod PL
  47.  
  48.         ChrBNow = AscB(Mid(Password, PosNow + 1, 1)) Xor 17
  49.  
  50.         TempDByte = (ByteIn(i) - ChrBNow)
  51.  
  52.         If TempDByte < 0 Then
  53.  
  54.             ByteFinal = 256 - Abs(TempDByte)
  55.  
  56.         Else
  57.  
  58.             ByteFinal = TempDByte
  59.  
  60.         End If
  61.  
  62.         ByteOut(i) = ByteFinal
  63.  
  64.         If i Mod 500 = 0 Then
  65.             DoEvents
  66.             'RaiseEvent DecryptProgress(i, UBound(ByteIn))
  67.         End If
  68.  
  69.     Next i
  70.  
  71.     SaveBinaryArray TempPathName & "myHMS.tmp", ByteOut
  72.   
  73.     FleeFile = FreeFile
  74.     Open TempPathName & "myHMS.tmp" For Binary As FleeFile
  75.         ' Getting the DataBase Parameters.
  76.         Get FleeFile, 1, Bit()
  77.         DecryptFile = StrConv(Bit, vbUnicode)
  78.     Close FleeFile
  79.     
  80.     Kill TempPathName & "myHMS.tmp"
  81.     Exit Function
  82. 1
  83.     DecryptFile = ""
  84.  
  85. End Function
  86.  
  87. Public Function EncryptFile(Source As String, Password As String) As Boolean
  88.  
  89. On Error GoTo 1
  90.   Dim ByteIn() As Byte
  91.   Dim ByteOut() As Byte
  92.   Dim ChrBNow As Integer
  93.   Dim PosNow As Integer
  94.   Dim TempByte As Integer
  95.  
  96.   ' Decrypt
  97.   Dim TempDByte As Integer
  98.   Dim ByteFinal As Integer
  99.   Dim i As Long
  100.   Dim j As Long
  101.   Dim PL As Integer
  102.  
  103.     ByteIn() = ReadBinaryArray(Source)
  104.  
  105.     ReDim ByteOut(LBound(ByteIn) To UBound(ByteIn)) As Byte
  106.  
  107.     PL = Len(Password)
  108.  
  109.     For i = LBound(ByteIn) To UBound(ByteIn)
  110.  
  111.         PosNow = i Mod PL
  112.  
  113.         ChrBNow = AscB(Mid$(Password, PosNow + 1, 1)) Xor 17
  114.         'ChrBNow = 1
  115.  
  116.         TempByte = (ByteIn(i) + ChrBNow) Mod 256
  117.  
  118.         TempDByte = (TempByte - ChrBNow)
  119.  
  120.         If TempDByte < 0 Then
  121.  
  122.             ByteFinal = 256 - Abs(TempDByte)
  123.  
  124.         Else
  125.  
  126.             ByteFinal = TempDByte
  127.  
  128.         End If
  129.  
  130.         ByteOut(i) = TempByte
  131.         
  132.         If i Mod 500 = 0 Then
  133.             DoEvents
  134.         End If
  135.  
  136.     Next i
  137.  
  138.     SaveBinaryArray TempPathName & "myHMS.tmp", ByteOut
  139.     FileCopy TempPathName & "myHMS.tmp", Source
  140.     Kill TempPathName & "myHMS.tmp"
  141.     EncryptFile = True
  142.     Exit Function
  143.     
  144. 1
  145.     EncryptFile = False
  146.  
  147. End Function
  148.  
  149. Public Function ReadBinaryArray(ByVal Source As String)
  150.  
  151.   Dim bytBuf() As Byte
  152.   Dim intN     As Long
  153.   Dim t        As Integer
  154.   Dim n As Long
  155.  
  156. On Error GoTo myErr
  157.     t = FreeFile
  158.     Open Source For Binary Access Read As #t
  159.         ReDim bytBuf(1 To LOF(t)) As Byte
  160.         Get #t, , bytBuf()
  161.  
  162.         ReadBinaryArray = bytBuf()
  163. myErr:
  164.     Close #t
  165.  
  166. End Function
  167.  
  168. Public Sub SaveBinaryArray(ByVal Filename As String, WriteData() As Byte)
  169.  
  170.   Dim t As Integer
  171.  
  172. On Error GoTo myErr
  173.     t = FreeFile
  174.     Open Filename For Binary Access Write As #t
  175.         Put #t, , WriteData()
  176. myErr:
  177.     Close #t
  178.  
  179. End Sub
  180.  
  181. Private Function TempPathName() As String
  182.  
  183.   Dim strTemp As String
  184.  
  185.     ' Returns the name of the temporary directory of Windows.
  186.     strTemp = String$(100, Chr$(0)) '* Create a buffer.
  187.     GetTempPath 100, strTemp  ' Get the temporary path.
  188.     ' Strip the rest of the buffer.
  189.     TempPathName = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
  190.  
  191. End Function
  192.