Check if the first 9 characters of subject line is 'FORMIMAGE'

D

Derek

Registered User.
Local time
Yesterday, 22:36
Joined
May 4, 2010
Messages
234
Hi guys,

I got the following code which will check the mailbox and extract data from them into .pdf and .txt file.

I have to amend the script so it will check the subject line for each email and it should extract data from only those emails whose subject line start with 'FORMIMAGE' and ignore the rest.

Can anyone please help me in this ? Thanks

Code: 
Public Declare Function GetPrivateProfileStringA Lib "Kernel32" (ByVal strSection As String, _
   ByVal strKey As String, ByVal strDefault As String, ByVal strReturnedString As String, _
   ByVal lngSize As Long, ByVal strFileNameName As String) As Long
Public Sub Extract()
    
    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 TestMail As String
    Dim strSource As String
    Dim strUserID As String
    Dim sFileName As String
    Dim sAccountNo As String
    Dim strDocType As String
    Dim strSubject As String
    
    m = GetPrivateProfileString32("C:\test.ini", "SaveFolder", "FolderName")
    
    TestMail = GetPrivateProfileString32("C:\test.ini", "TestMailbox", "Mailbox")
    
    InputP = GetPrivateProfileString32("C:\test.ini", TestMail, "InputFolder")
    
    OutputP = GetPrivateProfileString32("C:\test.ini", TestMail, "CompleteFolder")
    
      
    strRowData = ""
    
    ' 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)
       
       
     strUserID = Environ$("username")

    
    For I = 1 To SubFolder.Items.Count
    
        messageArray = ""
        strRowData = ""
    
        Set myItem = SubFolder.Items(1)
        
        msgtext = Trim(myItem.Body)
        
                
       'search for specific text
       
        delimtedMessage = Replace(Trim(msgtext), "Name of Borrower(s)", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Account Number(s)", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Property Address", "###")
        delimtedMessage = Replace(delimtedMessage, "Contact Telephone Number", "###")
        delimtedMessage = Replace(delimtedMessage, "Requested start date of payment break", "###")
        delimtedMessage = Replace(delimtedMessage, "My employment status is", "###")
        
    
        messageArray = Split(delimtedMessage, "###")
    

        For j = 1 To 11
    
            strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, " "), vbTab, "")
    
        Next j
        
        strRowData = Replace(strRowData, " " & vbCrLf, vbCrLf)
        
        strNo = Split(strRowData, "|")
        
        strAccNo = strNo(1)
                  
        sFileName = "abc"
        
                      
        sFilePath = m & sFileName & ".txt"
        
        ' Create .txt file
        
        Set objFile = objFS.CreateTextFile(sFilePath, False)
      
        With objFile
             .WriteLine strRowData
        End With
        
        ' Create .pdf file of the selected email item
                       
        Dim objDoc As Object, objInspector As Object
    
        Set objInspector = myItem.GetInspector
        Set objDoc = objInspector.WordEditor
        
        objDoc.ExportAsFixedFormat m & sFileName & ".pdf", 17
    
        Set objInspector = Nothing
        Set objDoc = Nothing
 
        ' move email to complete folder after processing
         
        myItem.Move myDestFolder
  
    Next I
        
        objFile.Close
    
    End Sub

Public Function GetPrivateProfileString32(ByVal strFileName As String, ByVal strSection As String, ByVal strKey As String, Optional strDefault) As String
Dim strReturnString As String, lngSize As Long, lngValid As Long
    On Error Resume Next
    If IsMissing(strDefault) Then strDefault = ""
    strReturnString = Space(2048)
    lngSize = Len(strReturnString)
    lngValid = GetPrivateProfileStringA(strSection, strKey, strDefault, strReturnString, lngSize, strFileName)
    GetPrivateProfileString32 = Left(strReturnString, lngValid)
'   On Error GoTo 0
End Function
 
Hi. Untested, but probably something along this line.

If Left(MyItem.Subject, 9)="FORMIMAGE" Then

Sent from phone...
 
I would use the Left() function on the subject field.?
 
Guys - I know I can use Left function but where in the code it needs to be used as I want the code to check the first email subject line and if it's not 'FORMIMAGE' then ignore it and move to the next one .

Any help will be much appreciated .
 
Jeez :(
Try
Code: 
If Left(MyItem.Subject,9)="FORMIMAGE" then
......Do all your processing here
End if
Next I

Plus shouldn't
Code: 
Set myItem = SubFolder.Items(1)
be
Code: 
Set myItem = SubFolder.Items(I)
 
Gasman , I have added a line of code to check for first 9 characters of subject line . Not sure why the FOR loop (For I = 1 To SubFolder.Items.Count) is not picking up the emails from top to bottom . It's randomly picking the emails and ignoring few as well
Code: 
Public Declare Function GetPrivateProfileStringA Lib "Kernel32" (ByVal strSection As String, _
   ByVal strKey As String, ByVal strDefault As String, ByVal strReturnedString As String, _
   ByVal lngSize As Long, ByVal strFileNameName As String) As Long
Public Sub Extract()
    
    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 TestMail As String
    Dim strSource As String
    Dim strUserID As String
    Dim sFileName As String
    Dim sAccountNo As String
    Dim strDocType As String
    Dim strSubject As String
    
    m = GetPrivateProfileString32("\\vm000000172\vfile\XML Transfer\COVID-19\MBP Term Extensions\Config\test.ini", "SaveFolder", "FolderName")
    
    TestMail = GetPrivateProfileString32("\\vm000000172\vfile\XML Transfer\COVID-19\MBP Term Extensions\Config\test.ini", "TestMailbox", "Mailbox")
    
    InputP = GetPrivateProfileString32("\\vm000000172\vfile\XML Transfer\COVID-19\MBP Term Extensions\Config\test.ini", TestMail, "InputFolder")
    
    OutputP = GetPrivateProfileString32("\\vm000000172\vfile\XML Transfer\COVID-19\MBP Term Extensions\Config\test.ini", TestMail, "CompleteFolder")
    
      
    strRowData = ""
    
    ' 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
    
    strUserID = Environ$("username")
      
    For I = 1 To SubFolder.Items.Count
    
    
        Set myItem = SubFolder.Items(I)
              
        If Left(myItem.Subject, 9) = "HUB2IMAGE" Then
        
        messageArray = ""
        strRowData = ""
        msgtext = Trim(myItem.Body)
                      
                 
       'search for specific text
       
        delimtedMessage = Replace(Trim(msgtext), "Property location", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Have you received a letter confirming your payment break is ending, which includes the deferred amount?", "###")
        delimtedMessage = Replace(Trim(delimtedMessage), "Account Number", "###")
        delimtedMessage = Replace(delimtedMessage, "Is any part of your mortgage interest only?", "###")
        delimtedMessage = Replace(delimtedMessage, "Alternative options", "###")
        delimtedMessage = Replace(delimtedMessage, "What type of mortgage do you have? ", "###")
        delimtedMessage = Replace(delimtedMessage, "Account Number", "###")
        delimtedMessage = Replace(delimtedMessage, "Full Name", "###")
        delimtedMessage = Replace(delimtedMessage, "Phone Number", "###")
        delimtedMessage = Replace(delimtedMessage, "Email", "###")
        delimtedMessage = Replace(delimtedMessage, "Postcode", "###")
        
        messageArray = Split(delimtedMessage, "###")
    

        For j = 1 To 11
    
            strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, " "), vbTab, "")
    
        Next j
        
        strRowData = Replace(strRowData, " " & vbCrLf, vbCrLf)
        
        strNo = Split(strRowData, "|")
        
        strAccNo = strNo(2)
                  
        sFileName = strAccNo & "-" & "Payment Break Request" & "-" & "Payment Break TE" & "-" & "HUBCUST" & "-" & strUserID & "--" & Format(Now, "yyyymmddhhmm")
        
        sFilePath = m & sFileName & ".txt"
        
        ' Create .txt file
        
        Set objFile = objFS.CreateTextFile(sFilePath, False)
      
        With objFile
             .WriteLine strRowData
        End With
        
        ' Create .pdf file of the selected email item
                       
        Dim objDoc As Object, objInspector As Object
    
        Set objInspector = myItem.GetInspector
        Set objDoc = objInspector.WordEditor
        
        objDoc.ExportAsFixedFormat m & sFileName & ".pdf", 17
    
        Set objInspector = Nothing
        Set objDoc = Nothing
 
        ' move email to complete folder after processing
         
        myItem.Move myDestFolder
        
        End If
  
    Next I
        
        objFile.Close
    
    End Sub

Public Function GetPrivateProfileString32(ByVal strFileName As String, ByVal strSection As String, ByVal strKey As String, Optional strDefault) As String
Dim strReturnString As String, lngSize As Long, lngValid As Long
    On Error Resume Next
    If IsMissing(strDefault) Then strDefault = ""
    strReturnString = Space(2048)
    lngSize = Len(strReturnString)
    lngValid = GetPrivateProfileStringA(strSection, strKey, strDefault, strReturnString, lngSize, strFileName)
    GetPrivateProfileString32 = Left(strReturnString, lngValid)
'   On Error GoTo 0
End Function
 
Generally that loop will work if you are just moving through the emails.
I tend to use Selected and select those involved.

However you are moving emails? Generally you work backwards in that case I believe, same as if you delete emails.
 
I tried to change the For loop to below but it's still missing few emails :
Code: 
For Each Item In SubFolder.Items
    
    'If TypeOf Item Is Outlook.MailItem Then
        Set oMail = Item
 
Derek said:
I tried to change the For loop to below but it's still missing few emails :
Code: 
For Each Item In SubFolder.Items
  
    'If TypeOf Item Is Outlook.MailItem Then
        Set oMail = Item
Click to expand...
Hi. You may have missed what @Gasman was saying earlier. Instead of using this:

For I = 1 To SubFolder.Items.Count

or this:

For Each Item In SubFolder.Items

You should try this:

For i = SubFolder.Items.Count To 1 Step -1
 
Yes I have tried that as well nut no joy :(
Code: 
For I = (SubFolder.Items.Count - 1) To 0 Step -1
    
    'Set E_Mail = strInboxFolder.Items(I)
    
        Set myItem = SubFolder.Items(I)
 
Well if you cannot get it to work as is, take another approach.?
Process the emails but DO NOT move them.
Then run another quick loop, moving them?

Not ideal, but should work?
 
You must log in or register to reply here.

Similar threads

D
Outlook macro to extract data from emails to .txt file
Replies
5
Views
1,271
theDBguy
theDBguy
D
Extract email body contents into .txt file
Replies
13
Views
1,466
Isaac
Isaac
A
Using Ini files to create text file (with various sections on it ) to store values
Replies
3
Views
979
arnelgp
arnelgp
D
Code to check if entry is in the right format
Replies
7
Views
1,338
dedjloco
D
V
Excel - VBA - how to make sure that the loop continues even if a file is not there
Replies
3
Views
2,739
vid
V

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom