Tread

' modMultiThreading.bas - The module provides support for multi-threading.
' © The trick, 2015

Option Explicit

Private Type uuid
  data1 As Long
  data2 As Integer
  data3 As Integer
  data4(7) As Byte
End Type

Private Type threadData
  lpParameter As Long
  lpAddress   As Long
End Type

Private tlsIndex    As Long  ' Index of the item in the TLS. There will be data specific to the thread.
Private lpVBHeader  As Long  ' Pointer to VBHeader structure.
Private hModule     As Long  ' Base address.
Private lpAsm       As Long  ' Pointer to a binary code.

' // Create a new thread
Public Function vbCreateThread(ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Dim InIDE   As Boolean
If LogActivo Then Call qfLog("vbCreateThread 2: " & lpStartAddress)
Debug.Assert MakeTrue(InIDE)

  If InIDE Then
      Dim ret As Long
      ret = DispCallFunc(ByVal 0&, lpStartAddress, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(lpParameter)), CVar(0))
      If ret Then
         Err.Raise ret
      End If
      Exit Function
  End If

  ' Alloc new index from thread local storage
  If tlsIndex = 0 Then
      tlsIndex = TlsAlloc()
      If tlsIndex = 0 Then Exit Function
  End If
  ' Get module handle
  If hModule = 0 Then
      hModule = GetModuleHandle(ByVal 0&)
  End If
  ' Create assembler code
  If lpAsm = 0 Then
      lpAsm = CreateAsm()
      If lpAsm = 0 Then Exit Function
  End If
  ' Get pointer to VBHeader and modify
  If lpVBHeader = 0 Then
      lpVBHeader = GetVBHeader()
      If lpVBHeader = 0 Then Exit Function
      ModifyVBHeader lpAsm
  End If

  Dim lpThreadData    As Long
  Dim tmpData         As threadData
  ' Alloc thread-specific memory for threadData structure
  lpThreadData = HeapAlloc(GetProcessHeap(), 0, Len(tmpData))

  If lpThreadData = 0 Then Exit Function
  ' Set parameters
  tmpData.lpAddress = lpStartAddress
  tmpData.lpParameter = lpParameter
  ' Copy parameters to thread-specific memory
  GetMem8 tmpData, ByVal lpThreadData
  ' Create thread
  vbCreateThread = CreateThread(ByVal lpThreadAttributes, dwStackSize, AddressOf ThreadProc, ByVal lpThreadData, dwCreationFlags, lpThreadId)
End Function
' // Initialize runtime for new thread and run procedure
Private Function ThreadProc(lpParameter As threadData) As Long
  Dim iid         As uuid
  Dim clsid       As uuid
  Dim lpNewHdr    As Long
  Dim hHeap       As Long

  ' Initialize COM
  vbCoInitialize ByVal 0&
  ' IID_IUnknown
  iid.data4(0) = &HC0: iid.data4(7) = &H46
  ' Store parameter to thread local storage
  TlsSetValue tlsIndex, lpParameter
  ' Create the copy of VBHeader
  hHeap = GetProcessHeap()
  lpNewHdr = HeapAlloc(hHeap, 0, &H6A)
  CopyMemory ByVal lpNewHdr, ByVal lpVBHeader, &H6A
  ' Adjust offsets
  Dim names()     As Long
  Dim diff        As Long
  Dim Index       As Long

  ReDim names(3)
  diff = lpNewHdr - lpVBHeader
  CopyMemory names(0), ByVal lpVBHeader + &H58, &H10

  For Index = 0 To 3
      names(Index) = names(Index) - diff
  Next

  CopyMemory ByVal lpNewHdr + &H58, names(0), &H10
  ' This line calls the binary code that runs the asm function.
  VBDllGetClassObject VarPtr(hModule), 0, lpNewHdr, clsid, iid, 0
  ' Free memeory
  HeapFree hHeap, 0, ByVal lpNewHdr
  HeapFree hHeap, 0, lpParameter
End Function
' // Get VBHeader structure
Private Function GetVBHeader() As Long
  Dim ptr     As Long

  ' Get e_lfanew
  GetMem4 ByVal hModule + &H3C, ptr
  ' Get AddressOfEntryPoint
  GetMem4 ByVal ptr + &H28 + hModule, ptr
  ' Get VBHeader
  GetMem4 ByVal ptr + hModule + 1, GetVBHeader
End Function

' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader(ByVal newAddress As Long)
  Dim ptr     As Long
  Dim old     As Long
  Dim flag    As Long
  Dim count   As Long
  Dim size    As Long

  ptr = lpVBHeader + &H2C
  ' Are allowed to write in the page
  VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
  ' Set a new address of Sub Main
  GetMem4 newAddress, ByVal ptr
  VirtualProtect ByVal ptr, 4, old, 0

  ' Remove startup form
  GetMem4 ByVal lpVBHeader + &H4C, ptr

  ' Get forms count
  GetMem2 ByVal lpVBHeader + &H44, count

  Do While count > 0
      ' Get structure size
      GetMem4 ByVal ptr, size
      ' Get flag (unknown5) from current form
      GetMem4 ByVal ptr + &H28, flag
      ' When set, bit 5,
      If flag And &H10 Then
          ' Unset bit 5
          flag = flag And &HFFFFFFEF
          ' Are allowed to write in the page
          VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
          ' Write changet flag
          GetMem4 flag, ByVal ptr + &H28
          ' Restoring the memory attributes
          VirtualProtect ByVal ptr, 4, old, 0

      End If

      count = count - 1
      ptr = ptr + size
  Loop
End Sub

' // Create binary code.
Private Function CreateAsm() As Long
  Dim hMod    As Long
  Dim lpProc  As Long
  Dim ptr     As Long

  hMod = GetModuleHandle(ByVal StrPtr("kernel32"))
  lpProc = GetProcAddress(hMod, "TlsGetValue")

  If lpProc = 0 Then Exit Function

  ptr = VirtualAlloc(ByVal 0&, &HF, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)

  If ptr = 0 Then Exit Function

  ' push  tlsIndex
  ' call  TLSGetValue
  ' pop   ecx
  ' push  DWORD [eax]
  ' push  ecx
  ' jmp   DWORD [eax + 4]

  GetMem4 &H68, ByVal ptr + &H0:          GetMem4 &HE800, ByVal ptr + &H4
  GetMem4 &HFF590000, ByVal ptr + &H8:    GetMem4 &H60FF5130, ByVal ptr + &HC
  GetMem4 &H4, ByVal ptr + &H10:          GetMem4 tlsIndex, ByVal ptr + 1
  GetMem4 lpProc - ptr - 10, ByVal ptr + 6

  CreateAsm = ptr
End Function

Private Function MakeTrue(Value As Boolean) As Boolean
  MakeTrue = True: Value = True
End Function