Super slow Assistants API responses

Hello, I am just starting with API Assistant and have the problem with status of my prompt.
Here is my code (VBA):

'1. Check if my assistant (assistantID) exists
url = "https://api.openai.com/v1/assistants/" & assistantID

    ' Create XMLHTTP object
Set http = CreateObject("MSXML2.XMLHTTP")
With http
    .Open "POST", url, False
    .setRequestHeader "Content-Type", "application/json"
    .setRequestHeader "Authorization", "Bearer " & apiKey
    .setRequestHeader "OpenAI-Beta", "assistants=v2"
    .Send
    response = .responseText
End With
Debug.Print "Assistnt Response: " & response

'2. Create Thread and Run in one step
url = "https://api.openai.com/v1/threads/runs"
payload = "{""assistant_id"": """ & assistantID & """, ""thread"": {""messages"": [{""role"": ""user"", ""content"": """ & JsonEncode(mailbody) & """}]}}"
Debug.Print "Tekst payload " & payload

    ' Create XMLHTTP object
Set http = CreateObject("MSXML2.XMLHTTP")

With http
    .Open "POST", url, False
    .setRequestHeader "Content-Type", "application/json"
    .setRequestHeader "Authorization", "Bearer " & apiKey
    .setRequestHeader "OpenAI-Beta", "assistants=v2"
    .Send payload
    response = .responseText
End With
Debug.Print "Run response: " & response

'3. Get Thread ID (created in the previous step)
Set jsonParsed = ParseJson(response)
threadID = jsonParsed("thread_id")
Debug.Print "Pobrane threadId: " & threadID

'4. Get Run ID (created in the previous step)
Set jsonParsed = ParseJson(response)
runId = jsonParsed("id")
Debug.Print "Pobrane runId: " & runId

'5. Get Run status
url = "https://api.openai.com/v1/threads/" & threadID & "/runs/" & runId

    ' Create XMLHTTP object
Set http = CreateObject("MSXML2.XMLHTTP")

 'here should be the loop repeating code in each 3 seconds to check status
With http
    .Open "GET", url, False
    .setRequestHeader "Content-Type", "application/json"
    .setRequestHeader "Authorization", "Bearer " & apiKey
    .setRequestHeader "OpenAI-Beta", "assistants=v2"
    .Send
    response = .responseText
End With
Debug.Print "Run status: " & response

Set jsonParsed = ParseJson(response)
runStatus = jsonParsed("status")
Debug.Print "Status runa: " & runStatus
'end of the loop

The problem is that the status is ‘in progress’ since about an hour or more. What is wrong with that?

Here is the answer of API:

Run status: {
“id”: “run_eu…”,
“object”: “thread.run”,
“created_at”: 1722676908,
“assistant_id”: “asst_ik…”,
“thread_id”: “thread_…”,
“status”: “in_progress”,
“started_at”: 1722676908,
“expires_at”: 1722677508,
“cancelled_at”: null,
“failed_at”: null,
“completed_at”: null,
“required_action”: null,
“last_error”: null,
“model”: “gpt-4o”,
“instructions”: “Introduction:\Here are instructions for the assistant with the Single Source of Truth…”,
“tools”: ,
“tool_resources”: {},
“metadata”: {},
“temperature”: 1.0,
“top_p”: 1.0,
“max_completion_tokens”: null,
“max_prompt_tokens”: null,
“truncation_strategy”: {
“type”: “auto”,
“last_messages”: null
},
“incomplete_details”: null,
“usage”: null,
“response_format”: “auto”,
“tool_choice”: “auto”,
“parallel_tool_calls”: true
}