Welcome to VBAX LisaB. Here is your 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 ProdMail As String
m = "\\fs2-facturing\A955724$\Email Scrapper\"
ProdMail = "amanpreet.kaur@boi.com"
InputP = "New Apps"
OutputP = "Completed Apps"
strRowData = ""
' Code to extract emails from specific subfolder within shared folder
Set olRecip = mynamespace.CreateRecipient(ProdMail)
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
messageArray = ""
strRowData = ""
Set myitem = SubFolder.Items(1)
msgtext = Trim(myitem.Body)
'search for specific text
delimtedMessage = Replace(Trim(msgtext), "Unique Reference", "###")
delimtedMessage = Replace(Trim(delimtedMessage), "Account Name", "###")
delimtedMessage = Replace(Trim(delimtedMessage), "Sort Code", "###")
delimtedMessage = Replace(delimtedMessage, "Account Number", "###")
delimtedMessage = Replace(delimtedMessage, "Date of Birth", "###")
delimtedMessage = Replace(delimtedMessage, "Contact Number", "###")
messageArray = Split(delimtedMessage, "###")
For j = 1 To 6
strRowData = Replace(Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, " "), vbTab, "")
Next j
strRowData = Replace(strRowData, " " & vbCrLf, vbCrLf)
sFilePath = m & "Form" & I & "-" & Format(Now, "ddmmyyhhmmss") & ".txt"
Set objFile = objFS.CreateTextFile(sFilePath, False)
With objFile
.WriteLine strRowData
End With
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