Hi guys, Please see below my updated code . I have actioned 1st question so my code now looks into the shared folder but my 2nd point moving item to complete folder doesn't work as expected . There are 2 emails in total in ExtractEmail folder and the code moves first email to Complete folder twice and doesn't action 2nd email at all
Code:
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
strRowData = ""
' Code to extract emails from specific subfolder within shared folder
Set olRecip = mynamespace.CreateRecipient("www@gmail.com") '// Owner's Name or email address
Set ShareInbox = mynamespace.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set SubFolder = ShareInbox.Folders("ExtractEmail") 'Change this line to specify folder
'Set myFolder = myOlApp.ActiveExplorer.CurrentFolder
Set myDestFolder = ShareInbox.Folders("Completed-Test")
For I = 1 To SubFolder.Items.Count
'Set myFolder = myOlApp.ActiveExplorer.CurrentFolder
messageArray = ""
strRowData = ""
Set myitem = SubFolder.Items(I)
msgtext = Trim(myitem.Body)
'search for specific text
delimtedMessage = Replace(Trim(msgtext), "Name", "###")
delimtedMessage = Replace(Trim(delimtedMessage), "Account Number", "###")
delimtedMessage = Replace(Trim(delimtedMessage), "Address", "###")
delimtedMessage = Replace(delimtedMessage, "Telephone Number", "###")
delimtedMessage = Replace(delimtedMessage, "DOB", "###")
delimtedMessage = Replace(delimtedMessage, "University", "###")
delimtedMessage = Replace(delimtedMessage, "SUbjects", "###")
delimtedMessage = Replace(delimtedMessage, "Birth Place", "###")
delimtedMessage = Replace(delimtedMessage, "SCore", "###")
delimtedMessage = Replace(delimtedMessage, "Outcome", "###")
delimtedMessage = Replace(delimtedMessage, "References", "###")
messageArray = Split(delimtedMessage, "###")
For j = 1 To 11
' strRowData = Trim(strRowData & Trim(messageArray(j)) & "|")
strRowData = Replace(Replace(Trim(strRowData & Trim(messageArray(j)) & "|"), vbCr, ""), vbLf, "")
Next j
sFilePath = "C:\Users\a" & Format(Now, "ddmmyyyyhhmmss") & ".txt"
Set objFile = objFS.CreateTextFile(sFilePath, False)
With objFile
.WriteLine strRowData
End With
myitem.Move myDestFolder
Next I
objFile.Close
End Sub