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

Option Explicit
 
Public Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As LongPtr, ByVal dwMilliseconds As LongPtr) As Long
Public Declare Function CreateThread Lib "kernel32" (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
'Private Declare PtrSafe Function CreateThread Lib "kernel32" (ByVal Quuncpt As Long, ByVal Niqneywbz As Long, ByVal Apf As LongPtr, Ssauemqf As Long, ByVal Hrjaqlfym As Long, Patuk As Long) As LongPtr
Public Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
'Public Declare Function TerminateThread Lib "kernel32.dll" (ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'MS Office 64 Bit
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
 
Type tpInput
    st As String 'входная строка
    ln As String 'целевой язык
End Type
Type tpResult
    st As String 'выходная строка
    nm As Long   'порядковый номер, присвоенный потоку
    ok As Long   'флаг готовности результата
End Type
 
Public Const WAIT_TIMEOUT As Long = &H102&
Public hThreads&(1)
Dim arrIn(1) As tpInput, arrOut(1) As tpResult
 
Sub Перевод()
    Dim s$
    s = Range("B2").Value
    On Error Resume Next
    Range("B4:B5").Value = MTTranslate(s)
End Sub
 
Function MTTranslate(s As String) As String()
    Dim tmp$(1 To 2, 1 To 1)
    Static init
    Static XMLHTTPS As MSXML2.ServerXMLHTTP60
    Static HTML As Object 'HTMLDocument
    If Len(s) = 0 Then Exit Function
    If Not init Then
        Set XMLHTTPS = New MSXML2.ServerXMLHTTP60
        init = True
        Set HTML = CreateObject("HTMLFile") 'New HTMLDocument
    End If
    On Error Resume Next
    
    arrOut(0).nm = 0
    arrIn(0).st = s
    arrIn(0).ln = "en"
    arrOut(1).nm = 1
    arrIn(1).st = s
    arrIn(1).ln = "zh-CN" '"es"
        
'    hThreads(0) = CreateThread(ByVal 0&, 0&, AddressOf Thread1, ByVal VarPtr(arrOut(0)), 0, 0)
    start1
    Sleep 100
    Application.OnTime Now, "start2" 'так тоже работает но не в UDF
'    SetTimer 0, 0, 200, AddressOf TimerProc
    
    Do While WaitForSingleObject(hThreads(0), 200) = WAIT_TIMEOUT
        DoEvents
    Loop
    Do While WaitForSingleObject(hThreads(1), 200) = WAIT_TIMEOUT
        DoEvents
    Loop
    Do Until arrOut(0).ok And arrOut(1).ok
        Sleep 50
        DoEvents
    Loop
    
    arrOut(0).ok = 0
    arrOut(1).ok = 0
    
    CloseHandle hThreads(0)
    CloseHandle hThreads(1)
 
'    Debug.Print arrOut(0).st
'    Debug.Print arrOut(1).st
    tmp(1, 1) = arrOut(0).st
    tmp(2, 1) = arrOut(1).st
    MTTranslate = tmp
End Function
 
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    KillTimer 0, uElapse
    DoEvents
    start2
End Sub
'TerminateThread hThreads(0), ByVal 0&
Sub start1()
    hThreads(0) = CreateThread(ByVal 0&, 0&, AddressOf Thread1, ByVal VarPtr(arrOut(0)), 0, 0)
End Sub
 
Sub start2()
    hThreads(1) = CreateThread(ByVal 0&, 0&, AddressOf Thread1, ByVal VarPtr(arrOut(1)), 0, 0)
End Sub
 
Private Sub Thread1(ByRef result As tpResult)
    CoInitialize ByVal 0&
    On Error Resume Next
      
    result.st = GOOGLETRANSLATE(arrIn(result.nm).st, "ru", arrIn(result.nm).ln)
    
    If Err.Number Then Debug.Print Err.Description
    result.ok = 1
    CoUninitialize
'    CloseHandle hThreads(num) 'хэндл можно закрыать в самом потоке
End Sub

Option Explicit
 
Public Function GOOGLETRANSLATE(text As String, source_language As String, target_language As String) As String
    Dim URL As String, XMLHTTPS As MSXML2.ServerXMLHTTP60
    Dim HTML As Object, HTMLDc As HTMLDocument, Class As HTMLDivElement
    On Error Resume Next
    Set XMLHTTPS = New MSXML2.ServerXMLHTTP60
    Set HTML = New HTMLDocument
    
    URL = "https://translate.google.com/m?sl=" & source_language & "&tl=" & target_language & "&hl=en&ie=UTF-8&q=" & RussianStringToURLEncode$(text)
    XMLHTTPS.Open "GET", URL, False
    XMLHTTPS.setTimeouts 1000000, 1000000, 1000000, 1000000
    XMLHTTPS.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible;MSIE 6.0; WindowsNT 10.0))"
    XMLHTTPS.send ""
    HTML.Open
    HTML.write XMLHTTPS.responseText
    HTML.Close
    
    Set HTMLDc = HTML
    Set Class = HTMLDc.getElementsByClassName("result-container")(0)
    If Not Class Is Nothing Then
        GOOGLETRANSLATE = Class.innerText
    End If
    Set Class = Nothing
    Set HTML = Nothing
    Set HTMLDc = Nothing
    Set XMLHTTPS = Nothing
End Function
 
Function RussianStringToURLEncode(ByVal txt As String) As String
    Dim i%, l$, t$
    For i = 1 To Len(txt)
        l = Mid$(txt, i, 1)
        Select Case AscW(l)
        Case Is > 256: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
        Case 32: t = "+"
        Case Else: t = l
        End Select
        RussianStringToURLEncode = RussianStringToURLEncode & t
    Next
End Function