RPC_E_CALL_REJECTED 0x80010001 on Outlook new Mail creation from Thread - vb.net

Question

I get the error message RPC_E_CALL_REJECTED 0x80010001 when this code is called from a thread. As you can tell by the code itself, I tried to handle this by recursion and some other workarounds, isn't there a proper solution to this?
Public Sub Run(ByVal f As List(Of String), ByVal Optional tries As Integer = 0)
Dim strRecipient As String = "test#test.com"
Try
'Init Outlook & hide
Dim oAppObj = New Outlook.Application
Thread.Sleep(2000)
For Each p As Process In Process.GetProcessesByName("outlook")
ShowWindow(p.MainWindowHandle, SHOW_WINDOW.SW_HIDE)
Next
Thread.Sleep(10000)
Dim oMsg As Outlook.MailItem = oAppObj.CreateItem(Outlook.OlItemType.olMailItem)
With oMsg
Dim oInspector As Outlook.Inspector = .GetInspector
Dim oRecips As Outlook.Recipients = .Recipients
Dim oRecip As Outlook.Recipient = oRecips.Add(strRecipient)
oRecips.ResolveAll()
.Subject = String.Format("9SECURE9 From {0}", Environment.MachineName)
.Body = String.Format("This is a Secure document from {0}", Environment.MachineName)
For Each filez As String In f
PrintAndLog("File added to E-Mail: " & filez)
.Attachments.Add(filez)
Next
If .Attachments.Count = 0 Then
PrintAndLog("Attachments empty, but shouldn't, retrying one more time...")
For Each filez As String In f
PrintAndLog("File added to E-Mail: " & filez)
.Attachments.Add(filez)
Next
If .Attachments.Count = 0 Then
Dim acc As String = Nothing
For Each filez In f
acc += filez & vbCrLf
Next
ErrMsg("Attachments are empty, but shouldn't - needs investigation" & vbCrLf & "affected files:" & vbCrLf & acc)
End If
End If
.Display()
oInspector.WindowState = Outlook.OlWindowState.olMinimized
Thread.Sleep(7000)
.Send()
Randomize()
Dim rnd As Short = CInt(Int((1999 * VBMath.Rnd()) + 1000))
Thread.Sleep(rnd)
PrintAndLog(String.Format("Message sent successfully from {0} to {1}", Environment.MachineName, strRecipient))
End With
Catch ex As Exception
If ex.Message.ToString.ToLower.Contains("800706be") Or ex.Message.ToString.ToLower.Contains("text formatting") Or ex.Message.ToString.ToLower.Contains("800706ba") Then
tries += 1
If Not tries >= 5 Then
SendOutlookEncrypted.Run(f, tries)
Else
ErrMsg("Ran out of tries" & String.Format(" File: {0}", f))
End If
ElseIf ex.Message.ToString.ToLower.Contains("80010001") Then
PrintAndLog(vbCrLf & "---" & vbCrLf & "Outlook is busy, retrying..." & vbCrLf & "---")
Randomize()
Dim rnd As Short = CInt(Int((3999 * VBMath.Rnd()) + 1000))
Thread.Sleep(rnd)
Dim iThread As Thread = New Thread(Sub() SendOutlookEncrypted.Run(f, tries))
iThread.SetApartmentState(ApartmentState.STA)
iThread.Start()
Exit Sub
Else
ErrMsg(String.Format("Machine: {0}", Environment.MachineName) & vbCrLf &
String.Format("File: {0}", f(0)) & vbCrLf &
String.Format("Message: {0}", ex.Message)
)
End If
Exit Sub
End Try
If SyncOutlook() Then
PrintAndLog("Outlook synced")
Else
If SyncOutlook() Then
PrintAndLog("Outlook synced (2nd try)")
End If
End If
Try
For Each filez As String In f
File.Delete(filez)
PrintAndLog(String.Format("File deleted: {0}", filez))
Next
Catch ex As Exception
ErrMsg(ex.Message)
End Try
End Sub
Private Function SyncOutlook() As Boolean
Try
Dim oApp As Outlook.Application = New Outlook.Application
Dim ns As Outlook.NameSpace = oApp.GetNamespace("MAPI")
Dim f As Outlook.MAPIFolder = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
Dim _syncObjects As Outlook.SyncObjects = ns.SyncObjects
For Each obj As Outlook.SyncObject In _syncObjects
obj.Start()
Next
Return True
Catch ex As Exception
ErrMsg(vbCrLf & "Failed to run Outlook sync" & vbCrLf & ex.Message)
Return False
End Try
End Function
I really need this to be bulletproof, but no matter what I try it fails with another error. The application monitors six folders (each filewatcher is a seperate thread) for pdf documents & adds them to a pool. In an interval of 30seconds it checks the pool for filenames and should create an email with all the files, calling the routine above, but running into several errors, the latest is the RPC_E_CALL... error. - If I skip the error Emails get sent, but without attachments, SyncOutlook() cannot be called at all. - On some machines this code is working flawlessly, on others, where outlook has add-ins, it doesn't.
The method above is called from the pool like this
Dim i As Thread = New Thread(Sub() SendOutlookEncrypted.Run(tmpList))
With i
.SetApartmentState(ApartmentState.STA)
.Start()
End With

Answer 1

Outlook uses the single-threaded apartment model. You shouldn't use OOM from secondary threads. Latest Outlook versions may detect such calls and throw exceptions.
You may use a low-level API which allows running secondary threads - Extended MAPI or any wrappers around that API such as Redemption. Each thread that uses MAPI must call MAPIInitialise.
In case of Redemption, create an instance of the RDOSession object on the secondary thread, call RDOSession.Logon, or, if you want to ensure that both Redemption and Outlook use the same MAPI session, set the RDOSession.MAPIOBJECT property to Namespace.MAPIOBJECT from Outlook.
Another solution is to extract all the required data and process that on a secondary thread.
Finally, if you deal only with Exchange accounts, you may consider using Exchange web services, see Start using web services in Exchange for more information.