Question

我在这个网站上找到了以下代码，它从outlook中的指定文件夹中复制电子邮件正文并将其粘贴到excel。但是，问题是我希望只将特定文本复制到excel。我插入了电子邮件样本，我想要复制突出显示的项目。仅供参考，数字字符的位置因电子邮件而异。例如。 “批号12345678”; “Bnumber 12345678”;“B＃87654321”;“BT＃12345678”

代码：

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

Answer 1

'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

Excel vba复制电子邮件正文中的某些文本

1 个答案: