使用vba从收件箱/当前文件夹中删除整个电子邮件链 [英] Deleting an entire email chain from inbox / current folder using vba

问题描述

我公司有很多人喜欢向整个公司发送电子邮件，并且总是回复所有人。很多时候，如果我离开办公桌一段时间，我最终会收到与我无关的20多封电子邮件的电子邮件链。相反，
比按主题排序然后删除组，我想选择使用vba删除整个链。我已经在Excel和Access中广泛使用了vba，但在Outlook中根本没用过，我很难找到我需要的信息才能获得
。

There are a lot of people at my company that like to send emails to the entire company and always reply all. Many times if I'm away from my desk for a little while, I end up with email chains that have nothing to do with me that are 20 or more emails. Rather than having to sort by subject then delete the group, I would like the option to delete an entire chain using vba. I've used vba pretty extensively in Excel and Access, but not at all in Outlook and I'm having trouble finding the information I need to get started.

最终，我想在工具栏中添加一个按钮，该按钮在打开时显示在电子邮件的顶部。但就目前而言，如果有人能够指出我如何搜索给定电子邮件所在的文件夹，以及
该链中的任何其他电子邮件，我会很高兴。

Ultimately, I would like to add a button to the toolbar that displays at the top of the email when it is opened. But for right now, I would be happy if somebody could just point me in the right direction on how to search the folder a given email is in for any other emails in that chain.

谢谢。

 

推荐答案

嗨Brendan

Hi Brendan

这是一根钓鱼竿......不是鱼......

This is a fishing rod... Not fish...

将以下代码放入Excel模块中。这与MS-Outlook一起工作。使用对Microsoft Outlook对象库的引用 你有可用....

Put the following code in a Excel module. This work with MS-Outlook. Use a Reference to the Microsoft Outlook Object Library  you have avalable....

Option Explicit
Public TWNAME As String
Public QTD_REPOS As Long
Public QTD_itens As Long
Public pstNOME As String

Public Sub MyPASTA()
 Dim APPOUTLOOK As Outlook.Application
 Dim MBOX As Outlook.NameSpace
 Dim PASTA As Outlook.MAPIFolder
 Dim STTEMP As String
 Dim NN As Long
 Dim NN1 As Long
 On Error GoTo ERROT
 Application.DisplayStatusBar = True
 TWNAME = "Vacuum Cleaner"
 QTD_itens = 0
 QTD_REPOS = 0
 Set APPOUTLOOK = New Outlook.Application
 Set MBOX = APPOUTLOOK.GetNamespace("MAPI")
 For Each PASTA In MBOX.Folders
 If UCase(Left(PASTA.Name, 16)) = "Mailbox" Then Exit For
 Next
 If PASTA Is Nothing Then
 MsgBox "Didn't Find Mailbox", vbCritical, TWNAME
 Exit Sub
 End If
 If PASTA.Folders.Count > 0 Then  'see if has childs
 Call ASPIRAR(PASTA, 1)
 Else
 Call SACA_REPOS(PASTA)
 End If
 Set PASTA = Nothing
 Set MBOX = Nothing
 Set APPOUTLOOK = Nothing
 Application.StatusBar = ""
 MsgBox Str(QTD_REPOS) + " mail - reports eliminated!", vbInformation, TWNAME
 Application.Quit
 Exit Sub
ERROT:
 Set PASTA = Nothing
 Set MBOX = Nothing
 Set APPOUTLOOK = Nothing
 MsgBox "Bad luck Error!" + vbLf + vbLf + "ERROR Nº" + Str(Err.Number) + vbLf + Err.Source + vbLf + Err.Description, vbCritical, TWNAME
 Range("A1").Select
End Sub

Public Sub VARRE_PASTA()
 Dim APPOUTLOOK As Outlook.Application
 Dim MBOX As Outlook.NameSpace
 Dim PASTA As Outlook.MAPIFolder
 Dim STTEMP As String
 Dim NN As Long
 Dim NN1 As Long
 On Error GoTo ERROT
 TWNAME = "Vacuum Cleaner"
 QTD_itens = 0
 QTD_REPOS = 0
 Set APPOUTLOOK = New Outlook.Application
 Set MBOX = APPOUTLOOK.GetNamespace("MAPI")
 Set PASTA = MBOX.PickFolder
 If PASTA Is Nothing Then
 Set MBOX = Nothing
 Set PASTA = Nothing
 Set APPOUTLOOK = Nothing
 MsgBox "You didn't pick a folder!", vbInformation, TWNAME
 Exit Sub
 End If
 If MsgBox("You have pick the folder: " + PASTA.Name, vbInformation + vbOKCancel, TWNAME) = vbCancel Then
 Set MBOX = Nothing
 Set PASTA = Nothing
 Set APPOUTLOOK = Nothing
 Exit Sub
 End If
 If PASTA.Folders.Count > 0 Then  'see if has childs
 Call ASPIRAR(PASTA, 1)
 Else
 Call SACA_REPOS(PASTA)
 End If
 Set PASTA = Nothing
 Set MBOX = Nothing
 Set APPOUTLOOK = Nothing
 Application.StatusBar = ""
 If QTD_REPOS = 0 Then
 MsgBox "No mail - reports founded!", vbExclamation, TWNAME
 Else
 MsgBox Str(QTD_REPOS) + " mail - reports eliminated!", vbInformation, TWNAME
 End If
 Exit Sub
ERROT:
 Set PASTA = Nothing
 Set MBOX = Nothing
 Set APPOUTLOOK = Nothing
 MsgBox "Bad luck Error!" + vbLf + vbLf + "ERROR Nº" + Str(Err.Number) + vbLf + Err.Source + vbLf + Err.Description, vbCritical, TWNAME
 Range("A1").Select
End Sub


Sub ASPIRAR(aPasta As Outlook.MAPIFolder, KOLUNA As Long)
 '' processa pasta
 Dim ProPasta As Outlook.MAPIFolder
 Dim PastaM As Outlook.MAPIFolder
 Dim NN As Long
 Call SACA_REPOS(aPasta)
 Set ProPasta = Nothing
 If aPasta.Folders.Count > 0 Then
 Set ProPasta = aPasta.Folders.GetFirst
 Call ASPIRAR(ProPasta, KOLUNA + 1)
 Else
 Do
  Set ProPasta = Nothing
  If aPasta.Parent = "Mapi" Then Exit Sub
  Set PastaM = aPasta.Parent
  NN = 1
  For Each ProPasta In PastaM.Folders
  If ProPasta = aPasta Then Exit For
  NN = NN + 1
  Next
  If NN >= PastaM.Folders.Count Then
  Set aPasta = PastaM
  KOLUNA = KOLUNA - 1
  If KOLUNA = 1 Then Exit Sub
  Else
  Set ProPasta = PastaM.Folders.Item(NN + 1)
  Call ASPIRAR(ProPasta, KOLUNA)
  Exit Do
  End If
 Loop
 End If
 Set ProPasta = Nothing
 Set PastaM = Nothing
 
End Sub


Sub SACA_REPOS(DaPasta As Outlook.MAPIFolder)
 Dim NN As Long
 Dim APAGOU As Boolean
DALHEO:
 If DaPasta.DefaultItemType <> olMailItem Then Exit Sub
 If DaPasta.Items.Count = 0 Then Exit Sub
 APAGOU = False
 For NN = 1 To DaPasta.Items.Count
 If DaPasta.Items.Item(NN).Class = 46 Then   ''' this is the line to change if you want to do something else ... good luck
  DaPasta.Items.Remove (NN)
  QTD_REPOS = QTD_REPOS + 1
  APAGOU = True
  Exit For
 End If
 QTD_itens = QTD_itens + 1
 Application.StatusBar = Space(10) + "Folder: " + DaPasta.Name + " - Total itens:" + Str(QTD_itens) + " - Total report's removed:" + Str(QTD_REPOS)
 Next
 If APAGOU Then GoTo DALHEO
End Sub

这篇关于使用vba从收件箱/当前文件夹中删除整个电子邮件链的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！