copy contents from outlook to excell - please help.

[joflo]

Hi All,

I'm very green with all this vba coding but ive managed to cobble some script together after reading a lot on this forum.

I have some questions.

1. is it possible to enter the current date and time in one of the case pattern elements?
(so that after it fills up all the relevant columns it enters a date stamp in the last column eg "F")
2. is it possible that if the pattern returns a null reading it will use a default text string ie. "no data"
3. how do I gather the information from the email information ie received date, sender, etc.

thanks in advance, loving all the information.

#######code#######

Option Explicit

Sub ACKtoExcel(olItem As Outlook.MailItem)


'Dim olItem As Outlook.MailItem

Dim xlApp As Object

Dim xlWB As Object

Dim xlSheet As Object

Dim vText, vText2, vText3, vText4, vText5 As Variant

Dim sText As String

Dim rCount As Long

Dim bXStarted As Boolean

Dim enviro As String

Dim strPath As String

Dim Reg1 As Object

Dim M1 As Object

Dim M As Object

Dim i As Long

Dim strCell As String



enviro = CStr(Environ("USERPROFILE"))

'the path of the workbook

strPath = enviro & "\Documents\Test123456.xlsx"


On Error Resume Next

Set xlApp = GetObject(, "Excel.Application")

If Err <> 0 Then

Application.StatusBar = "Please wait while Excel source is opened ... "

Set xlApp = CreateObject("Excel.Application")

bXStarted = True

End If

On Error GoTo 0

'Open the workbook to input the data

Set xlWB = xlApp.Workbooks.Open(strPath)

Set xlSheet = xlWB.Sheets("Sheet2")


' use this line if your using and active view

'Set olItem = Application.ActiveExplorer().Selection(1)


'Find the next empty line of the worksheet

rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row

rCount = rCount + 1


sText = olItem.Body


Set Reg1 = CreateObject("VBScript.RegExp")

For i = 1 To 6


With Reg1

Select Case i

Case 1

.Pattern = "(Incident Number\s*[:](.*))\n"

.Global = False

strCell = ("B")


Case 2

.Pattern = "(Engineer\s*Assigned\s*[:](.*))\n"

.Global = False

strCell = ("C")


Case 3

.Pattern = "(ETA\s*[:](.*))\n"

.Global = False

strCell = ("D")


Case 4

.Pattern = "(Part Assigned\s*[:](.*))\n"



.Global = False

strCell = ("E")


Case 5

.Pattern = "(Serial number\s*[:](.*))\n"

.Global = False

strCell = ("F")


Case 6

.Pattern = "(Part\s*to\s*site\s*via\s*[:](.*))\n"

.Global = False

strCell = ("G")



End Select


End With


If Reg1.Test(sText) Then


' each "(\w*)" and the "(\d)" are assigned a vText variable

Set M1 = Reg1.Execute(sText)

For Each M In M1

vText = Trim(M.SubMatches(1))

'vText2 = Trim(M.SubMatches(2))

'vText3 = Trim(M.SubMatches(3))


xlSheet.Range(strCell & rCount) = vText

'xlSheet.Range(strCell & rCount) = vText2

'xlSheet.Range(strCell & rCount) = vText3



Next

End If

Next i


xlWB.Close 1

If bXStarted Then

xlApp.Quit

End If


Set M = Nothing

Set M1 = Nothing

Set Reg1 = Nothing

Set xlApp = Nothing

Set xlWB = Nothing

Set xlSheet = Nothing

End Sub

 

[Diane Poremsky]

1. is it possible to enter the current date and time in one of the case pattern elements?
(so that after it fills up all the relevant columns it enters a date stamp in the last column eg "F")
2. is it possible that if the pattern returns a null reading it will use a default text string ie. "no data"
3. how do I gather the information from the email information ie received date, sender, etc.

1. Yes - use Date for the date only or Now for the current date and time.

2. Yes, if you use an if statement something like this:
if vText = "" then
vText = "no data"
end if

3. use field names
olItem.receivedtime
olItem.sendername
olItem.subject
etc. You can get the field names from the VBA Help (F2 when in the VBA editor)

 

[joflo]

thanks for the advice.
Ive tried to put this into the code but I am not making any progress.

sorry im not very good at this.

 

[Diane Poremsky]

Replace the section that begins and ends with the first and last lines - Next i rolls through the case statements - then when you are done, it grabs the fields from the email.

 For Each M In M1
vText = Trim(M.SubMatches(1))

If vText = "" Then
vText = "No Data"
End If

xlSheet.Range(strCell & rCount) = vText
Next
End If

Next i

xlSheet.Range("H" & rCount) = Date
xlSheet.Range("I" & rCount) = olItem.ReceivedTime
xlSheet.Range("J" & rCount) = olItem.SenderName
xlSheet.Range("K" & rCount) = olItem.SenderEmailAddress

xlWB.Close 1

 

[joflo]

When you put it like that, it almost seems obvious...

I cannot thank you enough.

Thank you
Thank you
Thank you