Dim mobjOLNamespace As Outlook.Namespace, Foldertosave As OlDefaultFolders 
Private Sub...
Dim objOutlook As New Outlook.Application
    Dim objNamespace As Outlook.Namespace 
Set objNamespace = objOutlook.Session
'...
end sub

Public Sub sendmessage()
On Error GoTo err1' решил вытащить всю функцию как есть
Dim mpf As Outlook.Folder, mpfInbox As Outlook.Folder
Dim OL_Itemmail As MailItem
Set mpfInbox = mobjOLNamespace.GetDefaultFolder(Foldertosave) ' какая то умолчальная папка, определенная ранее в модуле
Set mpf = mpfInbox.Folders.Item(miEvent.Zametka) ' подпапка в основной папке куда и будем закидывать наши нетленки
Set OL_Itemmail = mpf.Items.Add
With OL_Itemmail
    .To = miEvent.Firma
    .Subject = MyProfile
    .BodyFormat = olFormatPlain
    .Body = MyCategry
    Set .SaveSentMessageFolder = mpf ' присмотритесь сюда.
    .Display ' у меня писем немного, но и .send здесь это же просто кошмар
End With
Exit Sub
err1:
Select Case err.Number
Case -2147352567: Set mpf = mpfInbox.Folders.Item(miEvent.Zametka): Resume Next
Case -2147221233: Set mpf = mpfInbox.Folders.Add(miEvent.Zametka): Resume Next ' создадим папку если её нет
Case -2147024894: MsgBox "Ошибочный путь файла"
Case -2147467259
Case Else
            MsgBox "Error: " & err.Description & _
             " (" & err.Number & ")"
End Select

End Sub