Excel vba复制电子邮件正文中的某些文本
问题描述:
我在本网站中找到了以下代码,它从Outlook中的指定文件夹复制电子邮件正文并将其粘贴到Excel中。但是,问题是我只想将特定的文本复制到Excel中。我插入了电子邮件示例,并希望高亮显示的项目被复制。仅供参考,数字字符的位置因电子邮件而异。例如。 “批号12345678”; “B-号码12345678”; “B#87654321”; “BT#12345678”Excel vba复制电子邮件正文中的某些文本
CODE:
Option Explicit
Public gblStopProcessing As Boolean
Sub ParseBlockingSessionsEmailPartOne()
' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available
Dim wb As Workbook
Dim ws As Worksheet
Dim objFolder As Object
Dim objNSpace As Object
Dim objOutlook As Outlook.Application
Dim lngAuditRecord As Long
Dim lngCount As Long
Dim lngTotalItems As Long 'Count of emails in the Outlook folder.
Dim lngTotalRecords As Long
Dim i As Integer
Dim EmailCount As Integer 'The counter, which starts at zero.
'
On Error GoTo HandleError
'Application.ScreenUpdating = True
'Application.ScreenUpdating = False
'
Sheets("Merge Data").Select
'
' Initialize:
Set wb = ThisWorkbook
lngAuditRecord = 1 ' Start row
lngTotalRecords = 0
'
' Read email messages:
Application.ScreenUpdating = False
Set objOutlook = CreateObject("Outlook.Application")
Set objNSpace = objOutlook.GetNamespace("MAPI")
'
' Allow user to choose folder:#
Set objFolder = objNSpace.pickfolder
' Check if cancelled:
If objFolder Is Nothing Then
gblStopProcessing = True
MsgBox "Processing cancelled"
Exit Sub
End If
'
lngTotalItems = objFolder.Items.Count
If lngTotalItems = 0 Then
MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
gblStopProcessing = True
GoTo HandleExit
End If
If lngTotalItems > 0 Then
On Error Resume Next
Application.DisplayAlerts = False
wb.Worksheets("Merge Data").Delete
'wb.Worksheets("Audit").Delete
Application.DisplayAlerts = True
On Error GoTo HandleError
wb.Worksheets.Add After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
ws.Name = "Merge Data"
'Insert Title Row and Format NOTE: THE MACRO CAN BE USED TO PARSE OUT OTHER PARTS OF AN EMAIL.
' I JUST COMMENTED OUT THE LINES NOT USED FOR THE CURRENT PROJECT.
'ws.Cells(1, 1) = "Received"
ws.Cells(1, 1) = "Email Body"
ws.Cells(lngAuditRecord, 2) = "Subject"
'ws.Cells(lngAuditRecord, 4) = "Attachments Count"
'ws.Cells(lngAuditRecord, 4) = "Sender Name"
'ws.Cells(lngAuditRecord, 5) = "Sender Email"
ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
Selection.EntireRow.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
'Populate the workbook
For lngCount = 1 To lngTotalItems
Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems
i = 0
'read email info
While i < lngTotalItems
i = i + 1
If i Mod 50 = 0 Then Application.StatusBar = "Reading email messages " & Format(i/lngTotalItems, "0%") & "..."
With objFolder.Items(i)
'Cells(i + 1, 1).Formula = .ReceivedTime
Cells(i + 1, 1).Formula = .Body
Cells(i + 1, 2).Formula = .Subject
'Cells(i + 1, 4).Formula = .Attachments.Count
'Cells(i + 1, 5).Formula = .SenderName
'Cells(i + 1, 6).Formula = .SenderEmailAddress
End With
Wend
'Set objFolder = Nothing
ws.Activate
Next lngCount
lngTotalRecords = lngCount
'Format Worksheet
Columns("A:A").Select
Selection.ColumnWidth = 255
Cells.Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit
With Selection
.VerticalAlignment = xlTop
End With
Range("A1").Select
End If
'
' Check that records have been found:
If lngTotalRecords = 0 Then
MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
gblStopProcessing = True
GoTo HandleExit
End If
'
With Selection
Cells.Select
.VerticalAlignment = xlTop
.WrapText = True
End With
Range("A1").Select
'
HandleExit:
On Error Resume Next
Application.ScreenUpdating = True
Set objNSpace = Nothing
Set objFolder = Nothing
Set objOutlook = Nothing
Set ws = Nothing
Set wb = Nothing
If Not gblStopProcessing Then
MsgBox "Processing completed" & vbCrLf & vbCrLf & _
"Please check results", vbOKOnly + vbInformation, "Information"
End If
'Call ParseBlockingSessionsEmailPartTwo
Exit Sub
'
HandleError:
MsgBox Err.Number & vbCrLf & Err.Description
gblStopProcessing = True
Resume HandleExit
End Sub
答
'add two vars, 1) for the number you seek, and 2) position of "BT#" prefix
Dim strBTNum as String, lngPos as Long
'check to see if your body contains the BT#
lngPos = Instr(1, .Body, "BT#")
If lngPos > 0 Then 'you found your prefix at position lngPos
'so get the eight digit number
strBTNum = Mid(.Body, lngPos + 3, 8)
Else
strBTNum = "NotFound"
End If
'now put strBTNum wherever you want, maybe ...?
Cells(i + 1, 3).Formula = strBTNum
+0
谢谢JeffB。这工作! –
是它总是由'BT#'之前的8位数字?如果是这样,你可以使用'Mid'和'Instr'函数来解析文本。如果更复杂,请考虑RegEx方法。 –
是的。它总是8位数。感谢您的回复。我将untag vb.net 顺便说一句,你能帮我破解代码Mid和Instr函数吗?我对编程和编码很陌生,这就是为什么我正在进行大量研究。 –
您应该可以从Google获得足够多的基本信息。让我们知道你是否有特定的问题。 – Rdster