Question

我正在创建代码，其中Outlook会将所有电子邮件提取到现有的Excel文件中。

代码可以处理并提取所选文件夹中的所有电子邮件。但是，当我尝试在单独的文件夹上使用相同的代码时，假设已发送项目，它不会提取数据并打开Excel文件的只读版本。

我计划让Outlook和Excel Open。

如何使用任何Outlook文件夹并仍然更新Excel文件？

Private Sub Application_NewMailv7()

Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object

Dim objOL As Outlook.Application
Dim objItems As Outlook.Items

Dim myItem As MailItem

Dim myXLApp As Excel.Application
Dim myXLWB As Excel.Workbook
Dim StrBody As String
Dim TotalRows As Long, i As Long

Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items

Set myXLApp = New Excel.Application
myXLApp.Visible = True
Set myXLWB = myXLApp.Workbooks.Open("C:\Users\username\Desktop\Folder Name\SR Historyv2.xlsx")

Set excWks = myXLWB.Worksheets("Sheet1")

TotalRows = Sheets(1).Range("A65536").End(xlUp).Row
i = TotalRows + 1

For Each obj In objItems

    If obj.Class = olMail Then
        'Add a row for each field in the message you want to export
        excWks.Cells(i, 1) = Format(obj.ReceivedTime, "mm/dd/yyyy")
        excWks.Cells(i, 2) = obj.SenderEmailAddress
        excWks.Cells(i, 3) = obj.Subject

        i = i + 1

        'myXLWB.Save

    End If   
Next

Set obj = Nothing
Set objItems = Nothing
Set objFolder = Nothing
Set objOL = Nothing

End Sub

Answer 1

运行脚本后是否关闭SR Historyv2工作簿，或者是否要一直打开它？如果你打开它并再次运行脚本，它将再次打开工作簿，这将是只读的。对于第二个问题，我建议您查看Outlook中的ItemAdd事件。这仅在Outlook打开时才有效。 https://msdn.microsoft.com/en-us/library/office/aa171270(v=office.11).aspx

Answer 2

尝试以下操作，如果您想运行Outlook规则，请告诉我我将更新答案

Option Explicit
Sub Excel()
    Dim xlApp As Object 'Excel App
    Dim xlWB As Object 'WorkBook
    Dim xlSheet As Object
    Dim rngCount As Long
    Dim xlStarted As Boolean
    Dim xlPath As String
    Dim olExplorer As Explorer
    Dim olSelection As Selection
    Dim olItem As Outlook.MailItem
    Dim olMsg As Object
    Dim xlColA, xlColB, xlColC, xlColD As String

    '// Path of the Workbook - update only -> "\Folder Name\Folder Name\Book1.xlsx"
    xlPath = Environ("USERPROFILE") & _
        "\Documents\Temp\Book1.xlsx"

    '// Set up Excel Application
    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")
        xlStarted = True
    End If

    On Error GoTo 0
    '// Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(xlPath)
    Set xlSheet = xlWB.Sheets("Sheet1") ' or use (1) or (Sheet Name)

    '// Record msg        
    On Error Resume Next
    '// Find the next empty line of the worksheet
    rngCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row


    '// Get the values from Outlook
    Set olExplorer = Application.ActiveExplorer

    '// Select Outlook msg
    Set olSelection = olExplorer.Selection
    For Each olMsg In olSelection
        Set olItem = olMsg
        '// Info to collect
        xlColA = olItem.ReceivedTime
        xlColB = olItem.SenderName
        xlColC = olItem.SenderEmailAddress
        xlColD = olItem.To

        '// Write it to Excel sheet
        xlSheet.Range("A" & rngCount) = xlColA
        xlSheet.Range("B" & rngCount) = xlColB
        xlSheet.Range("C" & rngCount) = xlColC
        xlSheet.Range("D" & rngCount) = xlColD

        '// Go to Next row
        rngCount = rngCount + 1
    Next

    '// Save & Close Excel.Application
    xlWB.Close 1
    If xlStarted Then
        xlApp.Quit
    End If

    '// Clean up
    Set olItem = Nothing
    Set olMsg = Nothing
    Set olExplorer = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Answer 3

我让这段代码正常工作

html += "<td>" 
        + (sd.someKey.hasOwnProperty(s)  
          && sd.someKey.s.hasOwnProperty(a) 
          ?  sd.someKey.s.a 
          : "-" 
          + "</td>"

它保持文件打开，让其他宏访问它而不是只读。

更新当前文件

3 个答案: