Automatically Moving Emails to Excel Code works but I don t want the whole email body just a portion of it

Question

**Clarification That does work, however, it always inserts that extra text that I can't seem to get rid of.

I was able to pull together some code from other threads and have it migrate the desired information from emails to excel on its own. The issue is that everyone in my firm uses a sign-off at the bottom of their Outlook emails, which I extract into Excel as part of the body. That portion I don't want that

Here's and example of what that looks like

"What a great day

Name

Company

position

address

email links"

I was wondering if anyone has opinions or ideas I would be very grateful

Public Function IsWorkbookOpen(ByVal argFileName As String) As Boolean
    Dim fileID As Long, errNum As Long
    fileID = FreeFile()
    On Error Resume Next
    Open argFileName For Input Lock Read As #fileID
    errNum = Err.Number
    Close fileID
    IsWorkbookOpen = CBool(errNum)
End Function

Private Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    Dim Msg As Outlook.MailItem
    If TypeName(item) = "MailItem" Then
        Set Msg = item
        Dim xExcelFile As String
        Dim xExcelApp As Excel.Application
        Dim xWb As Excel.Workbook
        Dim xWs As Excel.Worksheet
        Dim xNextEmptyRow As Integer
        Dim xExcelRange As Excel.Range
        xExcelFile = "C:\Users\placeholder\Desktop\Testing\Test2.xlsx"
    End If
    If IsWorkbookOpen("C:\Users\placeholder\Desktop\Testing\Test2.xlsx") = True Then
        GoTo Skip
    Else
        Set xExcelApp = CreateObject("Excel.Application")
        Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
        Set xWs = xWb.Sheets(1)
        xWs.Activate
        Set xExcelRange = xWs.Range("A1")
        xExcelRange.Activate
        xExcelApp.Visible = True
    End If
Skip:
    MsgBox "New Ticket"
    On Error GoTo ErrHandler
    ' Set Outlook application object.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
    Dim objNSpace As Object
    Set objNSpace = objOutlook.GetNamespace("MAPI")
    Dim myFolder As Object
    Set myFolder = objNSpace.GetDefaultFolder(olFolderInbox).Folders("Automation").Items
    Dim objItem As Object
    Dim iRows, iCols As Integer
    iRows = 2
    For Each objItem In objNSpace.GetDefaultFolder(olFolderInbox).Folders("Automation").Items
        If objItem.Class = olMail Then
            Dim objMail As Outlook.MailItem
            Set objMail = objItem
            
            Cells(iRows, 1) = objMail.ReceivedTime
            Cells(iRows, 2) = objMail.SenderName
            Cells(iRows, 3) = objMail.SenderEmailAddress
            Cells(iRows, 4) = objMail.To
            Cells(iRows, 5) = objMail.Body
            
        End If
        iRows = iRows + 1
    Next
    Set objMail = Nothing
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing
ErrHandler:
    Debug.Print Err.Description
MsgBox "End of sub"
ProgramExit:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ProgramExit
End Sub```

narikkadan · Answer 1 · Apr 1, 2023

Use InStr function to find the beginning of the unwanted text and copy the text prior to that position using the Left function. I hope this helps you.