Многопоточность в VBA

'Модуль SendOut.bas
Public Declare Function OpenFileMapping Lib "kernel32" Alias "OpenFileMappingA" (ByVal dwDesiredAccess As Integer, ByVal bInheritHandle As Integer, ByVal lpName As String) As Long
Public Declare Function CreateFileMapping Lib "kernel32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpAttributes As Long, ByVal flProtect As Integer, ByVal dwMaximumSizeHigh As Integer, ByVal dwMaximumSizeLow As Integer, ByVal lpName As String) As Long
Public Declare Function MapViewOfFile Lib "kernel32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Public Declare Function UnmapViewOfFile Lib "kernel32" (ByVal lpBaseAddress As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function GetMem4 Lib "msvbvm60" (src As Any, Dst As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Const FILE_MAP_ALL_ACCESS = &H1F
Public Const PAGE_READWRITE = &H4
 
Public hMMF As Long, pMemfile As Long
 
Sub testOut()
    Dim VarOut As myType, ln&, integ(9) As Integer, bt(10) As Byte
    Dim sOut As String ' * 10    
 
    sOut = "fasasfaff"
    SendString sOut
    
End Sub
 
Sub SendString(myString$, Optional flSize& = 1000, Optional ln As Long, Optional ByVal nu As Long)
    Dim intArr%(), ineg%
    
    hMMF = OpenFileMapping(FILE_MAP_ALL_ACCESS, False, "MyMMF")
    If hMMF = 0 Then
        'создание MMF
'        hMMF = CreateFileMapping(-1, 0, PAGE_READWRITE, 0, LenB(myString) + 4, "MyMMF")
        hMMF = CreateFileMapping(-1, 0, PAGE_READWRITE, 0, flSize, "MyMMF")
        'получение начального адреса MMF
        pMemfile = MapViewOfFile(hMMF, FILE_MAP_ALL_ACCESS, 0, 0, 0)
        ThisWorkbook.Sheets(1).Cells(1, 1) = hMMF
        ThisWorkbook.Sheets(1).Cells(2, 1) = pMemfile
    End If
    If pMemfile Then
        'Получение указателя на первые 4 бита расшаренной памяти '!!
        GetMem4 pMemfile, ByVal VarPtr(nu) - 4
'        Stop 
        ln = Len(myString)
        ReDim intArr(ln - 1)
'        CopyMemory ByVal pMemfile, ln, 4
        CopyMemory ByVal pMemfile + 4, ByVal StrPtr(myString), ln * 2 'LenB(myString)
    Else
        MsgBox "Ошибка маппинга файла!"
        CloseHandleSub
        Exit Sub
    End If
    Debug.Print "Отправка на: "; pMemfile
    Stop
    ln = 0
End Sub
 
'Закрытие шаренной памяти
Sub CloseHandleSub()
    If hMMF = 0 Then
        hMMF = ThisWorkbook.Sheets(1).Cells(1, 1)
        pMemfile = ThisWorkbook.Sheets(1).Cells(2, 1)
    End If
    If hMMF Then
        Debug.Print UnmapViewOfFile(pMemfile)
        Debug.Print CloseHandle(hMMF)
        hMMF = 0
        pMemfile = 0
        ThisWorkbook.Sheets(1).Range("A1:A2").Clear
    End If
End Sub

'Модуль SendIn.bas
'Все те же декларации и константы
 
Sub testIn()
    Dim VarIn As myType, sIn$
    
    AcceptString sIn
    
    Debug.Print "Принята строка: "; sIn
End Sub
 
Sub AcceptString(myString As String, Optional ln As Long, Optional ByVal nu As Long)
    Dim pMemfile&, hMMF&, i&, t!
    'получение хендла 
    hMMF = OpenFileMapping(FILE_MAP_ALL_ACCESS, False, "MyMMF")
    
    If hMMF Then
        'получение начального адреса
        pMemfile = MapViewOfFile(hMMF, FILE_MAP_ALL_ACCESS, 0, 0, 0)
        GetMem4 pMemfile, ByVal VarPtr(nu) - 4
        'Stop 'получение указателя !!
        myString = Space(ln)
        'Получение строки из расшаренной памяти
        CopyMemory ByVal StrPtr(myString), ByVal pMemfile + 4, ln * 2
        Debug.Print "Принято на: "; pMemfile
    Else
        MsgBox "Отсутсвтует файл!"
    End If
    
    Stop
    ln = 1
    'отключение от расшаренной памяти
    UnmapViewOfFile pMemfile
    CloseHandle hMMF
End Sub

Option Explicit
 
Declare Function CreateThread Lib "kernel32" (ByVal lpSecurityAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function CoMarshalInterThreadInterfaceInStream Lib "ole32.dll" (riid As GUID, ByVal pUnk As IUnknown, ppStm As Long) As Long
Declare Function CoGetInterfaceAndReleaseStream Lib "ole32.dll" (ByVal pStm As Long, riid As GUID, pUnk As IUnknown) As Long
Declare Function CoInitialize Lib "ole32.dll" (ByVal pvReserved As Long) As Long
Declare Sub CoUninitialize Lib "ole32.dll" ()
' Structure to hold IDispatch GUID
 
Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type
 
Public IID_IDispatch As GUID
 
 
Private Sub cmdCreateApt_Click()
    Dim c As clsBackground
    Set c = New clsBackground
    StartBackgroundThreadApt c
End Sub
 
' Запуск теневого потока для этого обхекта использующий модель аппартамента возвращает 0 при ошибке
 
Public Function StartBackgroundThreadApt(ByVal qobj As clsBackground)
  Dim threadid&, hnd&, res&, threadparam&
  Dim tobj As Object
  
  Set tobj = qobj
  ' Правильный маршалированный подход
  InitializeIID
 
  res = CoMarshalInterThreadInterfaceInStream(IID_IDispatch, qobj, threadparam)
  If res <> 0 Then
      StartBackgroundThreadApt = 0
      Exit Function
  End If
  
  hnd = CreateThread(0, 2000, AddressOf BackgroundFuncApt, threadparam, 0, threadid)
  If hnd = 0 Then
      Exit Function                         'Возврат нуля в сл. ошибки
  End If
                                            'Нам больше не нужен хендл потока
  CloseHandle hnd
  StartBackgroundThreadApt = threadid
End Function
 
' Инициализация GUID структуры
Private Sub InitializeIID()
  Static Initialized As Boolean
  If Initialized Then Exit Sub
  With IID_IDispatch
    .Data1 = &H20400
    .Data2 = 0
    .Data3 = 0
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With
  Initialized = True
End Sub
 
Public Function BackgroundFuncApt(ByVal param As Long) As Long
  Dim qobj As Object
  Dim qobj2 As clsBackground
  Dim res&
  
  res = CoInitialize byval &0               'Инициализация OLE для данного аппартамента
                                            'Правильный модельный подход к апартаменту
  res = CoGetInterfaceAndReleaseStream(param, IID_IDispatch, qobj)
  Set qobj2 = qobj
  Do While Not qobj2.DoTheCount(10000)
  Loop
  qobj2.ShowAForm
                                            'Кроме того, вы можете поместить сюда функцию ожидания,
  CoUninitialize                            'затем вызовите функцию qobj, когда ожидание удовлетворено.
End Function                                'Все вызовы CoInitialize должны быть сбалансированы

Option Explicit
' Class clsBackground
' MTDemo 3 - Multithreading example
' Copyright © 1997 by Desaware Inc. All Rights Reserved
Event DoneCounting()
 
Dim l As Long
 
Public Function DoTheCount(ByVal finalval&) As Boolean
    Dim s As String
    If l = 0 Then
        s$ = "In Thread " & App.ThreadID
        MsgBox s$
    End If
    l = l + 1
    If l >= finalval Then
        l = 0
        DoTheCount = True
        MsgBox "Done with counting"
        RaiseEvent DoneCounting
    End If
End Function
 
Public Sub ShowForm()
    Form1.Show
End Sub