Outlook macro to extract data from emails to .txt file

[Derek]

Hi All,

The below macro works fine and extract the data from emails into .txt file . The only thing not working is question number 3 "Do you think you’ll be able to start making your full monthly payments again after 3 months?" has got apostrophe sign and the macro is not considering it a question and it's considered as answer to the Question 2 instead which is not correct. Is there any way to deal with apostrophe sign ?

Public Sub PB2()
On Error Resume Next
   
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")
    Dim objFS As New Scripting.FileSystemObject
    Dim objFile As Scripting.TextStream
    Dim FilePath As String
    Dim sFilePath As String
    Dim fileNumber As Integer
    Dim strRowData As String
    Dim strDelimiter As String
    Dim myDestFolder As Outlook.Folder
    Dim olRecip As Outlook.Recipient
    Dim ShareInbox As Outlook.MAPIFolder
    Dim SubFolder As Object
    Dim j As Integer
    Dim m As String
    Dim InputF As String
    Dim OutputP As String
    Dim ProdMail As String
    Dim FileOp As Boolean
   
    m = GetPrivateProfileString32("U:\Test.ini", "SaveFolder", "FolderName")
   
    TestMail = GetPrivateProfileString32("U:\Test.ini", "TestMailbox", "Mailbox")
     
    InputP = GetPrivateProfileString32("U:\Test.ini", TestMail, "InputFolder")
          
    OutputP = GetPrivateProfileString32("U:\Test.ini", TestMail, "CompleteFolder")
            
    strRowData = ""
   
    sFilePath = m & "Extract" & ".txt"
   
    FileOp = FileExists(sFilePath)
   
    If FileOp = True Then
       MsgBox "Extract.txt file already exists in the folder" & vbCr & "Please archive that file in order to run the next extract."
       Exit Sub
    End If
       
    ' Code to extract emails from specific subfolder within shared folder
    Set olRecip = mynamespace.CreateRecipient(TestMail)
    Set ShareInbox = mynamespace.GetSharedDefaultFolder(olRecip, olFolderInbox) ' Look into Inbox emails
    Set SubFolder = ShareInbox.Folders(InputP) 'Change this line to specify folder
    Set myDestFolder = ShareInbox.Folders(OutputP)
      
    If ShareInbox.Folders(InputP) = 0 Then
       MsgBox "New Apps folder doesn't exist"
       Exit Sub
    End If
   
    If ShareInbox.Folders(OutputP) = 0 Then
       MsgBox "Completed Apps folder doesn't exist"
       Exit Sub
    End If
   
         
    'For I = 1 To SubFolder.Items.Count
   
    For I = SubFolder.Items.Count To 1 Step -1
   
        messageArray = ""
        strRowData = ""
   
        Set myItem = SubFolder.Items(I)
       
        If Trim(Left(myItem.Subject, 3)) = "PB2" Then
       
        msgtext = Trim(myItem.Body)
       
       
             
        'search for specific text
   
        delimtedMessage = Replace(Trim(msgtext), "Have you received an email ?", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Can you afford to start making your monthly payments again?", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Do you think you'll be able to start making your full monthly payments again after 3 months?", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "First Name (Account holder)", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Surname", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Account Number", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Home Phone Number", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Mobile Phone Number", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Next payment date on your current loan", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "My employment status is ", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "I work in the following sector", "###")
       ' delimtedMessage = Replace(Trim(delimtedMessage), "I am experiencing short term cash flow issues due to coronavirus?", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "My financial position was stable prior to coronavirus (ie. No financial difficulty)?", "###")
        'delimtedMessage = Replace(Trim(delimtedMessage), "Have you been dealing with our Collections team in relation to arrears on your account?", "###")
        'delimtedMessage = Replace(Trim(delimtedMessage), "I understand that the deferred payments will need to be made after the 3 month period", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Which of the statements below best reflects why you have requested a further payment break?", "###")

        messageArray = Split(delimtedMessage, "###")
       
       
                   
        For j = 1 To 13
   
            strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, " "), vbTab, "")
   
        Next j
       
        strRowData = Replace(strRowData, " " & vbCrLf, vbCrLf)
       
        MsgBox strRowData
                     
               
        Set objFile = objFS.CreateTextFile(sFilePath, False)
     
        With objFile
             .WriteLine strRowData
        End With
        
        myItem.Move myDestFolder
       
        End If
               
    Next I
   
        objFile.Close
End Sub

 

[theDBguy]

Hi. Just a guess but try doubling up the apostrophe. Otherwise, you'll have to step through the code to find out exactly where/when you have to add the extra single quote.

 

[Derek]

Can you tell me what change needs to be made ? I tried different ways at my end but no luck

 

[Gasman]

Or just use the full word?

 

[Isaac]

Can you tell me what change needs to be made ? I tried different ways at my end but no luck

Try:

delimtedMessage = Replace(Replace(Trim(delimtedMessage), "Do you think you'll be able to start making your full monthly payments again after 3 months?", "###"),"'","''")

 

[theDBguy]

Can you tell me what change needs to be made ? I tried different ways at my end but no luck

Like I said, though, I was just guessing, but try this. Otherwise, you'll have to step through the code to see where you really need to address the single quote. Hope this helps...

delimtedMessage = Replace(Trim(delimtedMessage), "Do you think you''ll be able to start making your full monthly payments again after 3 months?", "###")