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

0 votes

**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```
Apr 1, 2023 in Others by Kithuzzz
• 38,010 points
369 views

1 answer to this question.

0 votes

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.

answered Apr 1, 2023 by narikkadan
• 63,420 points

Related Questions In Others

0 votes
1 answer

Using excel I need to open PPT and create ".gif" image of a ."pdf" and save it

It appears happier if you get a ...READ MORE

answered Dec 24, 2022 in Others by narikkadan
• 63,420 points
260 views
0 votes
1 answer

Excel: Is it possible to reorder the data in 2 columns to match up if they have a certain number of characters / a string in common?

Try this: =LET(files,A1:A4, URLs,B1:B4, f,BYROW(files,LAMBDA(r,TEX ...READ MORE

answered Jan 21, 2023 in Others by narikkadan
• 63,420 points
262 views
0 votes
1 answer

Excel - How do I round a date type to the next hour if it is more than one minute

Add almost 30 minutes and it'll get ...READ MORE

answered Mar 27, 2023 in Others by narikkadan
• 63,420 points
195 views
0 votes
1 answer

How to automatically assign a color to the maximum and minimum values in a set of selected cells in Excel?

See Conditional Formatting, which may be accessed ...READ MORE

answered Apr 7, 2023 in Others by Kithuzzz
• 38,010 points
283 views
0 votes
1 answer

Embed picture in outlook mail body excel vba

The image needs to be added and ...READ MORE

answered Dec 16, 2022 in Others by narikkadan
• 63,420 points
4,431 views
0 votes
1 answer

VBA How to extract the date and time of arrival of a answered email

Use MailItem.ReceivedTime property. I hope this helps you ...READ MORE

answered Jan 9, 2023 in Others by narikkadan
• 63,420 points
2,088 views
0 votes
1 answer

Error populating email body from word documents

There is no need to use late ...READ MORE

answered Jan 15, 2023 in Others by narikkadan
• 63,420 points
882 views
0 votes
1 answer

Export All appointments and meetings (including recurring meetings) Excel VBA

However, when I use the code above ...READ MORE

answered Feb 13, 2023 in Others by narikkadan
• 63,420 points
1,132 views
0 votes
1 answer

How can I use a command button in excel to set the value of multiple cells in one click?

Try this: Private Scan As Integer Private Sub CommandButton1_Click() ...READ MORE

answered Oct 24, 2022 in Others by narikkadan
• 63,420 points
508 views
0 votes
1 answer

I want to make Excel read a value in Calc and copy it to my sheet in Excel

Here is the sample code that will allow ...READ MORE

answered Oct 27, 2022 in Others by narikkadan
• 63,420 points
275 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP