Question

我将在前言中说明我没有VBA知识，我可以读它，但我当然不能写它。我也花了很多时间寻找以前回答的问题，这些问题将为我提供一个解决方案，但没有找到足够类似的东西让我用我有限的知识进行调整。

我要做的是编写一个VBA脚本，该脚本将读取Outlook文件夹中所有电子邮件的主题，计算预定义的关键字并将结果写入Excel电子表格中的单独单元格。此外，阅读正文并将短语后出现的整个句子复制到Excel中的单元格。

这些电子邮件的格式固定：
主题：
[关键字，三种可能性] [关键字，三种可能性] [“！”要么 ”？”或者没有体的：
搜索引擎：[要复制的文字，单字]
关键字：[要复制的文字，一条连续的单句]

下面是我认为与我正在尝试做的相关的代码但不能拼凑成一个单独的脚本。用于在Outlook中读取单个选定的电子邮件，并根据预定义的模式将主题写入单独的Excel单元格：

Option Explicit
 Private Const xlUp As Long = -4162

 Sub CopyToExcel()
 Dim olItem As Outlook.MailItem
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim vText, vText2, vText3 As Variant
 Dim sText As String
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim Reg1 As Object
 Dim M1 As Object
 Dim M As Object

enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "\Documents\Tally.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")
     Set olItem = Application.ActiveExplorer().Selection()

    'Find the next empty line of the worksheet
     rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
     rCount = rCount + 1

     sText = olItem.Subject

     Set Reg1 = CreateObject("VBScript.RegExp")
    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric

    With Reg1
        .Pattern = "((\w*)\s*(\w*)\s*(\w*))"
    End With
    If Reg1.test(sText) Then

' each "(\w*)" and the "(\d)" are assigned a vText variable
        Set M1 = Reg1.Execute(sText)
        For Each M In M1
           vText = Trim(M.SubMatches(1))
           vText2 = Trim(M.SubMatches(2))
           vText3 = Trim(M.SubMatches(3))
        Next
    End If

  xlSheet.Range("B" & rCount) = vText
  xlSheet.Range("c" & rCount) = vText2
  xlSheet.Range("d" & rCount) = vText3

     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     Set M = Nothing
     Set M1 = Nothing
     Set Reg1 = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

一个脚本，它记录电子邮件的日期并计算发生的时间：

Const olFolderInbox = 6

Set objDictionary = CreateObject("Scripting.Dictionary")

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)

Set colItems = objFolder.Items

For Each objItem in colItems
    strDate = FormatDateTime(objItem.SentOn, vbShortDate)
    If objDictionary.Exists(strOnline) Then
        objDictionary.Item(strOnline) = objDictionary.Item(strOnline) + 1
    Else
        objDictionary.Add strOnline, "1"
    End If
Next

colKeys = objDictionary.Keys

For Each strKey in colKeys
    Wscript.Echo strKey, objDictionary.Item(strKey)
Next

一个简单的If语句，如果主题有这个，那么这样做（？）：

Dim strSubject As String
strSubject = Item.Subject
If strSubject Like "*example1*" or strSubject Like "*example2*" Then

对此的任何帮助都将非常感激，因为这不是我的专业领域。

Answer 1

你在这里获得了大部分作品，是的。但是你有一些困难。这是我可以在几分钟内完成的，无需测试。此代码的SOY似乎是用Excel（第一个代码）编写的，而您拥有的第二个函数看起来像本机Outlook VBA。

这两种功能都可以（相对容易地）移植到另一个应用程序（我已尝试过这样做，假设它最好从 Excel VBA运行此代码通常更容易使用界面），但我没有做任何guarnatees :)）

这是一般的想法，粗略的代码：

使用您的第二个脚本（循环遍历所有电子邮件的脚本）作为主脚本。

从循环中调用第一个脚本，根据需要使用您需要的逻辑对其进行修改，并避免每次重新打开文件。

注意：我在Outlook对象上使用后期绑定，因此希望可以从Excel VBA调用此函数，而无需引用Outlook库。此代码也未经过测试，因此请确保所有变量都已正确声明并输入。

Option Explicit Sub Main() Dim colItems as Object Dim objItem as Object Dim objOutlook as Object 'Outlook.Application Dim objNamespace as Object Dim objFolder as Object 'Outlook.Folder Dim objDictionary as Object 'Scripting.Dictionary Dim strSubject As String Const olFolderInbox = 6 Set objDictionary = CreateObject("Scripting.Dictionary") Set objOutlook = CreateObject("Outlook.Application") Set objNamespace = objOutlook.GetNamespace("MAPI") Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox) Set colItems = objFolder.Items For Each objItem in colItems '## Get the subject strSubject = objItem.Subject '## Check for the conditions: If strSubject Like "*example1*" or strSubject Like "*example2*" Then Call WriteToExcel(objOutlook, objItem, "C:\path\to\your\file.xlsx") '## MODIFY FILE PATH! End If Next Next End Sub Sub WriteToExcel(objItem As Object, $strPath) Dim olItem As Object 'Outlook.MailItem Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim sText As String Dim rCount As Long Dim txt as String Set xlApp = Application 'Assumes you're running this from EXCEL 'Check if the workbook already open For each xlWB = xlApp.Workbooks If xlWB.FullName = strPath Then Exit For Next If xlWB Is Nothing Then Set xlWB = xlApp.Workbooks.Open(strPath) Set xlSheet = xlWB.Sheets("Sheet1") 'Find the next empty line of the worksheet rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row rCount = rCount + 1 sText = objItem.Subject '## Prints the subject in Column B xlSheet.Range("B" & rCount) = sText '##### HERE IS WHERE YOU NEED TO COUNT YOUR KEYWORDS#### '####################################################### '####################################################### '####################################################### txt = olItm.Body '## Omitting lines that close Excel app & Workbook, etc. Set xlApp = Nothing Set xlWB = Nothing Set xlSheet = Nothing End Sub

VBA：Outlook邮箱文件夹，计算主题中的关键字＆amp;正文和导出到Excel

1 个答案: