2017-05-31 160 views
-1

我在本网站中找到了以下代码,它从Outlook中的指定文件夹复制电子邮件正文并将其粘贴到Excel中。但是,问题是我只想将特定的文本复制到Excel中。我插入了电子邮件示例,并希望高亮显示的项目被复制。仅供参考,数字字符的位置因电子邮件而异。例如。 “批号12345678”; “B-号码12345678”; “B#87654321”; “BT#12345678”Excel vba复制电子邮件正文中的某些文本

enter image description here

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 
+1

是它总是由'BT#'之前的8位数字?如果是这样,你可以使用'Mid'和'Instr'函数来解析文本。如果更复杂,请考虑RegEx方法。 –

+0

是的。它总是8位数。感谢您的回复。我将untag vb.net 顺便说一句,你能帮我破解代码Mid和Instr函数吗?我对编程和编码很陌生,这就是为什么我正在进行大量研究。 –

+1

您应该可以从Google获得足够多的基本信息。让我们知道你是否有特定的问题。 – Rdster

回答

0
'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。这工作! –

相关问题