Outlook VBA开发第四讲-全部回复时带附件

lb_bn

找这个功能找了很久了，谢谢楼主。

mirlean

我看了一下代码，其实楼主的代码很多都是不必要的，特别是工具栏中加入按钮，操作不当还会出现N多次按钮，完全可以删除，自己作一个按钮。
自定义工具栏-->命令-->宏-->拖到工具栏就行了（图标什么的都可以自己改，右键看看）。
另外，代码中有一句：
If Not objAtt.FileName Like "image???.???" Then
这个就把附件是以image开头的附件全部给略去了。
代码简化如下：
Sub vsoCommbandReplyAllWithAttach()

'出现错误时下一句代码继续运行
On Error Resume Next

Dim rpl As Outlook.mailItem
    Dim itm As Object
   
    Set itm = GetCurrentItem()
    If Not itm Is Nothing Then
        Set rpl = itm.ReplyAll
        CopyAttachments itm, rpl
        rpl.Display
    End If
   
    Set rpl = Nothing
    Set itm = Nothing

End Sub

Sub colInspectors_NewInspector(ByVal Inspector As Inspector)
      On Error Resume Next
     Dim objCommandBar As CommandBar
     Set objCommandBar = Inspector.CommandBars("ExcelClub")
     If (objCommandBar Is Nothing) Then
     Set objCommandBar = Inspector.CommandBars.Add("ExcelClub", msoBarTop, , True)
     Set vsoCommbandReplyAllWithAttachInspector = objCommandBar.Controls.Add(msoControlButton, , , , True)
     vsoCommbandReplyAllWithAttachInspector.Caption = "ReplayAll"
     vsoCommbandReplyAllWithAttachInspector.FaceId = 68
     vsoCommbandReplyAllWithAttachInspector.Style = msoButtonIconAndCaption
     objCommandBar.Visible = True
     Else
     Set vsoCommbandReplyAllWithAttachInspector = objCommandBar.Controls(1)
     End If
End Sub

Private Sub vsoCommbandReplyAllWithAttachInspector_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)

On Error Resume Next

Dim rpl As Outlook.mailItem
    Dim itm As Object
   
    Set itm = GetCurrentItem()
    If Not itm Is Nothing Then
        Set rpl = itm.ReplyAll
        CopyAttachments itm, rpl
        rpl.Display
    End If
    itm.Close olDiscard
    Set rpl = Nothing
    Set itm = 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

mirlean

Set rpl = itm.ReplyAll就是全部回复，所以写成这样Set rpl = itm.Reply，就是回复，而不是全部回复。

mirlean

还忘记删一段了。哈哈。。
简化如下：
Sub ReplyWithAttachments()
    Dim rpl As Outlook.MailItem
    Dim itm As Object
   
    Set itm = GetCurrentItem()
    If Not itm Is Nothing Then
        Set rpl = itm.ReplyAll
        CopyAttachments itm, rpl
        rpl.Display
    End If
   
    Set rpl = Nothing
    Set itm = 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

ak-aner

2007版的OUTLOOK打开MAIL没有按钮，如何添加，请教了！！！！

ncralan

下載試用，謝謝分享{:soso_e179:}{:soso_e100:}

pingguomeng

好用的很，版主加油！

steedch

需要，需要，谢谢楼主。正在找这方面的资料。

waterfis

过来支持一下了啊，呵呵

oldshuijing

mirlean 发表于 2012-3-27 18:55
我看了一下代码，其实楼主的代码很多都是不必要的，特别是工具栏中加入按钮，操作不当还会出现N多次按钮，完 ...

老大 我在自己加按钮的时候  想自己制作一个按钮  但是找不到这些图标存储的位置 没有办法选择 帮助看看在哪里吗