Создание раздела FreeBasic (голосование)

#ifndef unicode
#define unicode
#endif
 
#include "windows.bi"
#include "win\ole2.bi"
 
Const ProgId_SapiSpVoice = "SAPI.SpVoice"
 
If CoInitialize(0) <> S_OK Then
    Print "Не могу инициализировать COM."
    End(1)
End If
 
Dim CLSID_SapiSpVoice As CLSID = Any
Dim hr As HRESULT = CLSIDFromProgID(@ProgId_SapiSpVoice, @CLSID_SapiSpVoice)
 
If FAILED(hr) Then
    Print "Не могу разрешить CLSID_SapiSpVoice по ProgId_SapiSpVoice", Hex(hr)
    End(2)
End If
 
Dim pClassFactory As IClassFactory Ptr = NULL
hr = CoGetClassObject(@CLSID_SapiSpVoice, CLSCTX_INPROC, NULL, @IID_IClassFactory, @pClassFactory)
 
If FAILED(hr) Then
    Print "Ошибка в CoGetClassObject", Hex(hr)
    End(3)
End If
 
Dim pVoice As IDispatch Ptr = NULL
hr = pClassFactory->lpVtbl->CreateInstance(pClassFactory, NULL, @IID_IDispatch, @pVoice)
If FAILED(hr) Then
    Print "Не могу создать IDispatch", Hex(hr)
    End(4)
End If
 
' Получаем DISPID для вызываемой функции Speak
Const cNames As UINT = 1
' Массив с именами функций
Dim rgszNames(cNames - 1) As WString Ptr = {@"Speak"}
' Массив с DISPID
Dim rgDispId(cNames - 1) As DISPID = Any
 
hr = IDispatch_GetIDsOfNames( _
    pVoice, _
    @IID_NULL, _
    @rgszNames(0), _
    cNames, _
    GetUserDefaultLCID(), _
    @rgDispId(0) _
)
If FAILED(hr) Then
    Print "Не получил DISPID", Hex(hr)
    End(5)
End If
 
' Текст для чтения
Dim TextToSpeach As BSTR = SysAllocString("Добрый день! Как ваши дела?")
If TextToSpeach = NULL Then
    Print "Не могу выделить память для строки текста для чтения"
    End(6)
End If
 
Const ParamsCount As Integer = 1
 
' Инициализация массива параметров
Dim varParam(ParamsCount - 1) As VARIANT = Any
For i As Integer = 0 To ParamsCount - 1
    VariantInit(@varParam(i))
Next
 
' Тип параметра — строка
varParam(0).vt = VT_BSTR
varParam(0).bstrVal = TextToSpeach
 
Dim Params(0) As DISPPARAMS = Any
Params(0).rgvarg = @varParam(0)
Params(0).cArgs = ParamsCount
Params(0).rgdispidNamedArgs = NULL
Params(0).cNamedArgs = 0
 
' Результат вызова функции
Dim VarResult As VARIANT = Any
 
' Вызываем функцию
hr = IDispatch_Invoke( _
    pVoice, _
    rgDispId(0), _
    @IID_NULL, _
    GetUserDefaultLCID(), _
    DISPATCH_METHOD, _
    @Params(0), _
    @VarResult, _
    NULL, _
    NULL _
)
 
' Очистка
For i As Integer = 0 To ParamsCount - 1
    VariantClear(@varParam(i))
Next
IDispatch_Release(pVoice)
IClassFactory_Release(pClassFactory)

Procedure Test(*Pointer, Variable)
  
  ! MOV dword [p.p_Pointer], 20
  ! MOV dword [p.v_Variable], 30
  
  Debug *Pointer
  Debug Variable
EndProcedure
 
Test(0, 0)

EnableASM
 
Procedure TestProc(*Pointer, Variable)
   
  MOV *Pointer, 20
  MOV Variable, 30
  
  Debug *Pointer
  Debug Variable
EndProcedure
 
TestProc(0, 0)

CompilerIf #PB_Compiler_Thread = 0
  CompilerError "Включите поддержку многопоточности в настроках компилятора"
CompilerEndIf
 
Global Semaphore = CreateSemaphore()
Global Mutex     = CreateMutex()
Global NewList Queue()
 
Procedure Producer(Total)
 
  For i = 1 To Total
    Delay(Random(750) + 250)
    
    ; Работа с очередью всё же требует нормальной блокировки через Мьютекс для потокобезопасности
    LockMutex(Mutex)
      LastElement(Queue())
      AddElement(Queue())
      Queue() = i
    UnlockMutex(Mutex)    
 
    ; Сигнализируем, что в очереди новый элемент
    SignalSemaphore(Semaphore)
  Next i
    
EndProcedure
 
If CreateThread(@Producer(), 30)
 
  For i = 1 To 30  
    ; ожидаем наличия одного элемента
    WaitSemaphore(Semaphore)
    
    ; отображаем состояние очереди
    LockMutex(Mutex)
      Queue$ = "Queue:"
      ForEach Queue()
        Queue$ + " " + Str(Queue())
      Next Queue()
      Debug Queue$
    
      ; удаляем головной элемент из очереди
      FirstElement(Queue())
      DeleteElement(Queue())
    UnlockMutex(Mutex)
    
  Next i
 
EndIf