' Code of Module1
Option Explicit

Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (pArr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const FADF_FIXEDSIZE = &H10
Private Const FADF_HAVEVARTYPE = &H80

Private Type SAFEARRAYBOUND
   cElements As Long
   lLbound As Long
End Type

'Одномерный безопасный массив
Private Type SAFEARRAY1
   cDims As Integer
   fFeatures As Integer
   cbElements As Long
   cLocks As Long
   pvData As Long
   rgsabound( 0  To  0 ) As SAFEARRAYBOUND
End Type

'Одномерный безопасный массив с описателем типа элементов
Private Type SAFEARRAY1VT
   vtType As VbVarType
   sa As SAFEARRAY1
End Type

' --> Safe Array method
Private Sub Test_SafeArray(ByVal S As String)
 Dim a As SAFEARRAY1VT   'структура заголовка одномерного безопасного массива
 Dim WChars() As Integer 'массив кодов символов
 Dim ppsaWChars As Long
 'Заполнение структуры заголовка одномерного безопасного массива
 a.vtType = vbInteger
 With a.sa
    .cDims =  1 
    .fFeatures = FADF_HAVEVARTYPE Or FADF_FIXEDSIZE
    .cbElements = LenB(" ")
    '.cLocks = 1
    .pvData = StrPtr(S)     'Указываем на начало строки
    With .rgsabound( 0 )
       .lLbound =  1          'или 0, по вкусу
       .cElements = Len(S)  '+ 1, если хочется иметь завершающий ноль
    End With
 End With
 'Сопоставляем VB-шный массив Integer() и структуру
 ppsaWChars = ArrPtr(WChars())
 CopyMemory ByVal ppsaWChars, VarPtr(a.sa), LenB(ppsaWChars)
 'Используем элементы массива
 Dim i As Long
 For i = LBound(WChars) To UBound(WChars) Step  2 
    'Debug.Print ChrW$(WChars(i));
    WChars(i) = WChars(i) Xor  1  '<-- для разогрева, т.к.результат не сохранится
 Next i
 'Debug.Print
 'Возвращаем указатель массива в начальное состояние
 CopyMemory ByVal ppsaWChars,  0 &, LenB(ppsaWChars)
End Sub
' <-- End of Safe Array method

' Mid$() method
Sub Test_Mid(txt As String)
  Dim i As Long
  For i =  1  To Len(txt)
    Mid$(txt, i) = Chr$(Asc(Mid$(txt, i,  1 )) Xor  1 )
  Next
End Sub

' ByteArray method
Sub Test_ByteArray(txt As String)
  Dim b() As Byte, i As Long
  b = txt
  For i =  0  To UBound(b) Step  2 
    b(i) = b(i) Xor  1 
  Next
  txt = b
End Sub

' Time test of methods
Sub TimeTest()
  
  Dim txt As String, TestText As String, t As Date, i As Integer
  
  Const N =  100              ' <-- Test cycles amount
  Const X =  300000           ' <-- Test Unicode chars amount
  Const Pwd = "Password"    ' <-- For VB + Asm method only
  TestText = String(X, "-") ' <-- Test Unicode string
    
  ' Print test header
  Debug.Print String( 50 , "=")
  Debug.Print "TimeTest: Chars = " & X & "; Cycles = " & N
  Debug.Print String( 50 , "-")
  
  ' Test of Mid$() method
  txt = TestText
  t = Timer
  For i =  1  To N
    Test_Mid txt
  Next
  t = Timer - t
  PrintResult "MidArray", t, N, X
  
  ' Test of Byte array method
  txt = TestText
  t = Timer
  For i =  1  To N
    Test_ByteArray txt
  Next
  t = Timer - t
  PrintResult "ByteArray", t, N, X
  
  ' Test of Safe array method
  txt = TestText
  t = Timer
  For i =  1  To N
    Test_SafeArray txt
  Next
  t = Timer - t
  PrintResult "SafeArray", t, N, X
  
  ' Test of VB + Asm method
  txt = TestText
  t = Timer
  For i =  1  To N
    VbAsmCrypt txt, Pwd
  Next
  t = Timer - t
  PrintResult "VbAsm", t, N, X
    
End Sub

' Вывод результата тестирования
Private Sub PrintResult(Msg, t, N, X)
  Dim ChPerSec$
  ChPerSec = Format(N * X / t, "# ### ###")
  If Len(ChPerSec) <  11  Then ChPerSec = Space( 11  - Len(ChPerSec)) & ChPerSec
  Debug.Print Msg & ":", Format(t, "0.000") & " sec", ChPerSec & " char/sec"
End Sub


' Проверка кодирования: Xor 1
Sub HowMethodsAreWorking()
  Dim txt$, TestTxt$
  TestTxt = "1234567890qwertyйцукен"
  txt = TestTxt: Test_Mid txt: Debug.Print txt, "Test_Mid"
  txt = TestTxt: Test_ByteArray txt: Debug.Print txt, "Test_ByteArray"
  txt = TestTxt: Test_SafeArray txt: Debug.Print txt, "Test_SafeArray"; " <-- не сохраняет результат кодирования!"
  txt = TestTxt: VbAsmCrypt txt, Chr( 1 ): Debug.Print txt, "VbAsmCrypt"
End Sub

' Code of Module1
' Вариант с обратным вызовом скомпилированного ASM-кода
Option Explicit

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal ptrMC As Long, ByVal P1 As Long, ByVal P2 As Long, ByVal P3 As Long, ByVal P4 As Long) As Long
Const StrCode = "5589E55356578B450C85C074468B451485C0743F8B4D0CD1E18B550801CAF7D98B5D14D1E38B451001D8894510F7DB895D148B040A035D1032032B5D1081C30200000075038B5D1489040A81C10200000075DF31C05F5E5B89EC5DC21000"
Dim BinCode() As Byte, Ok As Boolean

Function VbAsmCrypt(Str As String, Password As String) As Boolean
    Dim i&
    If Len(Str) * Len(Password) =  0  Then Exit Function
    If Ok <> True Then
      ReDim BinCode( 93 )
      For i =  0  To  93 
        BinCode(i) = "&H" + Mid$(StrCode, i *  2  +  1 ,  2 )
      Next
      Ok = True
    End If
    CallWindowProc VarPtr(BinCode( 0 )), StrPtr(Str), Len(Str), StrPtr(Password), Len(Password)
    VbAsmCrypt = True
End Function