一个抽取outlook邮件信息的VBA script

Sub CopyToExcel()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim xSubject As String
Dim sTime As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:test.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
End If
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")

'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
    sTime = olItem.CreationTime
    xSubject = olItem.Subject
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
    rCount = rCount + 1
    xlSheet.Range("A" & rCount) = xSubject

    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
        If InStr(1, vText(i), "ID:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Message:") > 0 Then
            vItem = Split(vText(i), "Message Text:")
            'MsgBox vItem(1)
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If
         If InStr(1, vText(i), "Comments:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            'MsgBox vItem(1)
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If
            xlSheet.Range("E" & rCount) = sTime
    Next i
    xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
    xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set lItem = Nothing

End Sub

来自 “ ITPUB博客 ” ，链接：http://blog.itpub.net/11976525/viewspace-751644/，如需转载，请注明出处，否则将追究法律责任。