Question

我编写了这个脚本来搜索Outlook文件夹，其中包含一系列电子邮件，这些电子邮件在电子邮件正文中包含一定数量的信息，以便复制到Excel文件中。

当我第一次创建并运行脚本时，没有任何问题，这是我第二次运行它并且它的速度非常慢并且冻结了我的计算机。我注意到它似乎为每封电子邮件打开了一个新的Excel实例。

我很困惑，因为它第一次运行没有错误，没有更改脚本和第二次运行它，我不能让它完成因为计算机冻结。有没有办法不为每封电子邮件打开一个新实例？

我对修改整个代码并不感兴趣，但是如果我们能够以一种简单的方式提高它的效率，请指望我。

要明确的是，这是从Outlook运行的规则，每周运行一次。

 Sub CopyToExcel(olItem As Outlook.MailItem)
 Dim xlApp As Object
 Set xlApp = CreateObject("Excel.Application")
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim xlOpenWB As Object
 Dim vText 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 RegExp
 Dim M1 As MatchCollection
 Dim M As Match
 Dim xlUp As Long
 Dim FileName As String
 xlUp = -4162

FileName = "\Desktop\newhires" & Format(Date, "yyyyMMDD") & ".xlsx"

enviro = (Environ("USERPROFILE"))

'the path of the workbook VB function, don't change
 strPath = enviro & FileName

 'Add the workbook to input the data
     Set xlWB = xlApp.Workbooks.Add()
     xlWB.SaveAs (strPath)

     Set xlOpenWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlOpenWB.Sheets("newhires")
  'Find the next empty line of the worksheet
     rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row

     rCount = rCount + 1

'sText is content of the email
    sText = olItem.Body

    Set Reg1 = New RegExp

    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric

    With Reg1
        .pattern = "(Employee Number\s*[:]\s*(\d*))"
    End With
    If Reg1.test(sText) Then

        Set M1 = Reg1.Execute(sText)
        For Each M In M1
           vText = Trim(M.SubMatches(1))
        Next
    End If

    xlSheet.Range("A" & rCount) = vText
    vText.RemoveDuplicates Columns:=Array(1)
    xlOpenWB.Close 1

  xlApp.Quit
  Set Reg1 = Nothing
  Set xlApp = Nothing
  Set xlWB = Nothing
  Set xlSheet = Nothing
  Set xlOpenWB = Nothing

 End Sub

Answer 1

好的，所以你将这个作为规则运行，并将脚本作为操作。使用GetObject获取当前实例，如果发生错误，请创建一个。可能还想删除退出Excel的退出调用。

Sub CopyToExcel(olItem As Outlook.MailItem)
 On Error Resume Next
 Dim xlApp as Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim xlOpenWB As Object
 Dim vText 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 RegExp
 Dim M1 As MatchCollection
 Dim M As Match
 Dim xlUp As Long
 Dim FileName As String
 xlUp = -4162
'try and get the current running object
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then 'no object was found so create one
    Set xlApp = CreateObject("Excel.Application")
    Err.Clear
End If
FileName = "\Desktop\newhires" & Format(Date, "yyyyMMDD") & ".xlsx"

enviro = (Environ("USERPROFILE"))

'the path of the workbook VB function, don't change
 strPath = enviro & FileName

 'Add the workbook to input the data
     Set xlWB = xlApp.Workbooks.Add()
     xlWB.SaveAs (strPath)

     Set xlOpenWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlOpenWB.Sheets("newhires")
  'Find the next empty line of the worksheet
     rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row

     rCount = rCount + 1

'sText is content of the email
    sText = olItem.Body

    Set Reg1 = New RegExp

    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric

    With Reg1
        .Pattern = "(Employee Number\s*[:]\s*(\d*))"
    End With
    If Reg1.test(sText) Then

        Set M1 = Reg1.Execute(sText)
        For Each M In M1
           vText = Trim(M.SubMatches(1))
        Next
    End If

    xlSheet.Range("A" & rCount) = vText
    vText.RemoveDuplicates Columns:=Array(1)
    xlOpenWB.Close 1
  'removed xlApp.Quit
  xlApp = Nothing
  Set Reg1 = Nothing
  Set xlWB = Nothing
  Set xlSheet = Nothing
  Set xlOpenWB = Nothing

 End Sub

为什么将字符串从Outlook复制到Excel会为每封电子邮件打开一个新的Excel实例？

1 个答案: