Idon'tknowwhattoputhere
New Member
- Outlook version
- Outlook 2013 64 bit
- Email Account
- Exchange Server 2013
I recently converted from Lotus Notes to Outlook (don't ask me what took the company so long). In Lotus Notes there was a reply all with history and attachments feature that I used daily. Outlook doesn't offer so I created myself with help from this forum. However, when I use the Macro the message always "Pops Out" rather than staying in the preview window. Is there a way to make the message stay in the preview window? Code below
Sub ReplyAllWithAttachments()
Dim oReply As Outlook.MailItem
Dim oItem As Object
Set oItem = GetCurrentItem()
If Not oItem Is Nothing Then
Set oReply = oItem.ReplyAll
CopyAttachments oItem, oReply
oReply.Display
oItem.UnRead = False
End If
Set oReply = Nothing
Set oItem = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
Sub ReplyAllWithAttachments()
Dim oReply As Outlook.MailItem
Dim oItem As Object
Set oItem = GetCurrentItem()
If Not oItem Is Nothing Then
Set oReply = oItem.ReplyAll
CopyAttachments oItem, oReply
oReply.Display
oItem.UnRead = False
End If
Set oReply = Nothing
Set oItem = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub