AlphonseG
New Member
- Outlook version
- Outlook 365 32 bit
- Email Account
- Office 365 Exchange
Using Outlook Desktop 365 with Office 365 Exchange. I have a single account with multiple shared mailboxes.
On replying to received messages I want to send from the shared mailbox that the message was addressed to.
When composing a new message, I want to set the SentOnBehalfOfName based on the current folder and save the sent message in the same folder.
With many, many hours of research and trials, I've come up with the below code.
Everything works as desired EXCEPT, saving the new message in the current folder. Setting SaveSentMessageFolder causes Outlook to crash and restart, disabling all VBA on restarting.
Setting it manually works fine. How can I set the SaveSentMessageFolder without crashing?
On replying to received messages I want to send from the shared mailbox that the message was addressed to.
When composing a new message, I want to set the SentOnBehalfOfName based on the current folder and save the sent message in the same folder.
With many, many hours of research and trials, I've come up with the below code.
Everything works as desired EXCEPT, saving the new message in the current folder. Setting SaveSentMessageFolder causes Outlook to crash and restart, disabling all VBA on restarting.
Setting it manually works fine. How can I set the SaveSentMessageFolder without crashing?
Code:
Public WithEvents myItem As Outlook.MailItem
Public WithEvents myOlInspectors As Outlook.Inspectors
Private Const conDefaultSendAddress As String = "mydefaultaddress"
Sub Initialize_Handler()
On Error Resume Next
Set myOlInspectors = Application.Inspectors
If TypeName(Application.ActiveWindow) = "Explorer" Then
Set myItem = Application.ActiveExplorer.Selection.item(1)
ElseIf TypeName(Application.ActiveWindow) = "Inspector" Then
Set myItem = Application.ActiveInspector.CurrentItem
Else
Set myItem = Nothing
End If
End Sub
Private Sub Application_Startup()
Initialize_Handler '11/25/2022
End Sub
Private Sub myItem_Open(Cancel As Boolean)
'Set Send address and save folder for new email
Dim aE As Outlook.addressEntry
Dim strSaveFolder As String
Dim strFrom As String
Dim oFldr As Outlook.Folder
If myItem.Recipients.Count = 0 Then
strFrom = SendAddressForFolder
myItem.Recipients.Add (strFrom) 'Issue with SentOnBehalfOfName
myItem.Recipients.ResolveAll
Set aE = myItem.Recipients(1).addressEntry
myItem.Recipients.Remove (1)
myItem.SentOnBehalfOfName = strFrom
myItem.Sender = aE
strSaveFolder = NewMailSaveFolder
If strSaveFolder <> "" Then
Set oFldr = FindOlFolder(Application.Session.Folders(1), strSaveFolder)
Set myItem.SaveSentMessageFolder = oFldr 'crashes here
End If
End If
End Sub
Private Sub myOlInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
Dim msg As Outlook.MailItem
If Inspector.CurrentItem.Class = olMail Then
Set msg = Inspector.CurrentItem
If msg.Size = 0 Then
Set myItem = Inspector.CurrentItem
'can't set SentOnBehalfOfName here, it does not display
End If
End If
End Sub
Private Sub myItem_Forward(ByVal Forward As Object, Cancel As Boolean)
Call AccountToSendViaEx(Forward, False)
End Sub
Private Sub myItem_Reply(ByVal Response As Object, Cancel As Boolean)
Call AccountToSendViaEx(Response, True)
Debug.Print "reply"
End Sub
Private Sub myItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
Call AccountToSendViaEx(Response, True)
End Sub
Private Sub AccountToSendViaEx(ByRef Response As Object, ByVal replyAll As Boolean)
Response.SentOnBehalfOfName = ReplyAddressUse
End Sub
Private Function ReplyAddressUse() As String
Dim intRet As Integer
Dim strAddress As String
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Dim strRet As String
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
10 On Error GoTo ErrLine
20 Set recips = myItem.Recipients
30 For Each recip In recips
40 Set pa = recip.PropertyAccessor
50 strAddress = pa.GetProperty(PR_SMTP_ADDRESS)
60 If strAddress Like "*@mydomain*" Then
70 strRet = strAddress
80 Exit For
90 End If
100 Next recip
110 If strRet <> "" Then
120 ReplyAddressUse = strRet
130 Else
140 ReplyAddressUse = SendAddressForFolder
150 End If
ExitLine:
160 On Error Resume Next
170 Set recips = Nothing
180 Set recip = Nothing
190 Set pa = Nothing
200 Exit Function
ErrLine:
210 MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & "Line: " & Erl
220 Resume ExitLine
End Function
Private Function SendAddressForFolder() As String
Dim strCurrentFolder As String
Dim strRet As String
strCurrentFolder = Application.ActiveExplorer.CurrentFolder
Select Case strCurrentFolder
Case "mydesiredfolder1"
strRet = "mysharedmailbox1"
Case "mydesiredfolder2"
strRet = "mysharedmailbox2"
Case "mydesiredfolder3"
strRet = "mysharedmailbox3"
Case Else
strRet = conDefaultSendAddress
End Select
SendAddressForFolder = strRet
End Function
Private Function NewMailSaveFolder() As String
Dim strCurrentFolder As String
Dim strRet As String
strCurrentFolder = Application.ActiveExplorer.CurrentFolder
Select Case strCurrentFolder
Case "mydesiredfolder1"
strRet = strCurrentFolder
Case Else
strRet = ""
End Select
NewMailSaveFolder = strRet
End Function
Private Function FindOlFolder(ByRef objRootFolder As Object, ByVal strName As String) As Outlook.Folder
Dim objFldr As Outlook.Folder
For Each objFldr In objRootFolder.Folders
If objFldr.Name = strName Then
Set FindOlFolder = objFldr
Exit For
ElseIf objFldr.Folders.Count > 0 Then
Set FindOlFolder = FindOlFolder(objFldr, strName)
If Not FindOlFolder Is Nothing Then
Exit For
End If
End If
Next
End Function
Private Sub Application_ItemLoad(ByVal item As Object)
Call Initialize_Handler
End Sub
Last edited by a moderator:
