Outlook vba to copy date from email body to excel

[LisaB]

Hi All,

I have written the below vba code in outlook to extract data from email body on to .txt file. It worked great but I now need to amend this to copy the data from email body to excel spreadsheet . Can anyone please help me in this? The code should open excel workbook saved down in a shared folder and copy the data from the emails on to Sheet1 and then save/close it .

I am unable to add the code below as getting post denied message so please see attachment for code.

Thanks Lisa

[Aussiebear]

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