home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Simple_Mac2110964282008.psc / class / clsSimpleXOR.cls < prev   
Text File  |  2008-04-16  |  3KB  |  129 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 = "clsSimpleXOR"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15. Private m_Key()             As Byte
  16. Private m_KeyLen            As Long
  17. Private m_KeyValue          As String
  18. Public Event progress(Percent As Long)
  19.  
  20. Public Sub DecryptByte(ByteArray() As Byte, _
  21.                        Optional key As String)
  22.  
  23.     Call EncryptByte(ByteArray(), key)
  24.  
  25. End Sub
  26.  
  27. Public Sub DecryptFile(SourceFile As String, _
  28.                        DestFile As String, _
  29.                        Optional key As String)
  30.  
  31.   Dim Filenr      As Long
  32.   Dim ByteArray() As Byte
  33.  
  34.     If (Not FileExist(SourceFile)) Then
  35.         Exit Sub
  36.     End If
  37.     Filenr = FreeFile
  38.     Open SourceFile For Binary As #Filenr
  39.     ReDim ByteArray(0 To LOF(Filenr) - 1)
  40.     Get #Filenr, , ByteArray()
  41.     Close #Filenr
  42.     Call DecryptByte(ByteArray(), key)
  43.     If (FileExist(DestFile)) Then
  44.     
  45.         Kill DestFile
  46.     End If
  47.     Filenr = FreeFile
  48.     Open DestFile For Binary As #Filenr
  49.     Put #Filenr, , ByteArray()
  50.     Close #Filenr
  51.  
  52. End Sub
  53.  
  54. Public Sub EncryptByte(ByteArray() As Byte, _
  55.                        Optional ByVal key As String)
  56.  
  57.   
  58.   Dim Offset      As Long
  59.   Dim ByteLen     As Long
  60.   Dim ResultLen   As Long
  61.   Dim CurrPercent As Long
  62.   Dim NextPercent As Long
  63.  
  64.     If (Len(key) > 0) Then
  65.         Me.key = key
  66.     End If
  67.     ByteLen = UBound(ByteArray) + 1
  68.     ResultLen = ByteLen
  69.     For Offset = 0 To (ByteLen - 1)
  70.         ByteArray(Offset) = ByteArray(Offset) Xor m_Key(Offset Mod m_KeyLen)
  71.         If (Offset >= NextPercent) Then
  72.             CurrPercent = Int((Offset / ResultLen) * 100)
  73.             NextPercent = (ResultLen * ((CurrPercent + 1) / 100)) + 1
  74.             RaiseEvent progress(CurrPercent)
  75.         End If
  76.     Next '  OFFSET
  77.     If (CurrPercent <> 100) Then
  78.         RaiseEvent progress(100)
  79.     End If
  80.  
  81. End Sub
  82.  
  83. Public Sub EncryptFile(SourceFile As String, _
  84.                        DestFile As String, _
  85.                        Optional key As String)
  86.  
  87.   Dim Filenr      As Long
  88.   Dim ByteArray() As Byte
  89.  
  90.     If (Not FileExist(SourceFile)) Then
  91.         MsgBox "Source file doesn't exist", "SimpleXOR Error Procedure"
  92.         Exit Sub
  93.     End If
  94.     Filenr = FreeFile
  95.     Open SourceFile For Binary As #Filenr
  96.     ReDim ByteArray(0 To LOF(Filenr) - 1)
  97.     Get #Filenr, , ByteArray()
  98.     Close #Filenr
  99.     Call EncryptByte(ByteArray(), key)
  100.     If (FileExist(DestFile)) Then
  101.     Kill DestFile
  102.     End If
  103.     Filenr = FreeFile
  104.     Open DestFile For Binary As #Filenr
  105.     Put #Filenr, , ByteArray()
  106.     Close #Filenr
  107. Kill SourceFile
  108. End Sub
  109.  
  110. Public Property Let key(New_Value As String)
  111.  
  112.     If (m_KeyValue = New_Value) Then
  113.         Exit Property
  114.     End If
  115.     m_KeyValue = New_Value
  116.     m_KeyLen = Len(New_Value)
  117.     m_Key() = StrConv(m_KeyValue, vbFromUnicode)
  118.  
  119. End Property
  120. Public Function FileExist(strfilename As String) As Boolean
  121.     On Error Resume Next
  122.     FileExist = True
  123.         If FileLen(strfilename) = 0 Then
  124.             FileExist = False
  125.         End If
  126. End Function
  127.  
  128.  
  129.