Solved: Problem sending email to excel

[SeanJ]

I am using the following code http://www.vbaexpress.com/forum/show...6003&highlight

it hangs at the saving part of the code and it will overwrite the information in that file.

I will be receiving about 100 emails a day during a four or five days period in a month and I need to do matrix on the timing issue.

Please help.

Thanks

[Killian]

Hi Sean and welcome to VBAX

When you say "hangs", are you getting an error message or does the app just stop responding?

As I mentioned in the other thread, there can be some issues when using a rule or event to trigger a long routine. It seems to be a problem if the rule/event fires when a mail arrives and the routine is already running, hence the suggestoin to use the rule to move the mails only and then manually fire the script to process all the mails periodically. is that a possibility?

[SeanJ]

I have been running in debug mode and I found out that the program was asking for me to save the file. In doing so it overwrite what is there. I tried to have the excel application open and watch its process and I can not figue it out. If you want I can post what I have modified, and we can go from there.

[Killian]

OK, yes. post the code. I'm sure we can work something out

[SeanJ]

I found out what I was doing wrong. I left the file open during Debug and other stupid stuff, but I still need help tweaking the code. Here is the code.
[vba]Sub ProcessMail2Excel(myMailItem As MailItem)
'Macro purpose: Create an Excel instance via code
' using late binding. (No references required)

Dim xlApp As Object
Dim wbTarget As Object
Dim sFilename As String
Dim sFilepath As String
Dim lngTargetRow As Long
Dim strBody As String

'Assign the filename and path
sFilename = "Te1.xls"
sFilepath = "d:\Temp\"
'initialize the strin variable with the body text
'of the incoming mail item
strBody = myMailItem.Body

'Create a new instance of Excel
Set xlApp = CreateObject("Excel.Application")




'Open the workbook
xlApp.Workbooks.Open sFilepath & sFilename
xlApp.Visible = True

Set wbTarget = xlApp.Workbooks(sFilename)



'get the next free row
lngTargetRow = wbTarget.Sheets(1).Cells(wbTarget.Sheets(1).Rows.Count, 2).End(-4162).Row
If IsEmpty(wbTarget.Sheets(1).Cells(lngTargetRow, 2)) Then
lngTargetRow = 1
Else
lngTargetRow = lngTargetRow + 1
End If
'input the data by calling the text parsing function
' working on this part of the code
With wbTarget.Sheets(1).Cells(lngTargetRow, 1)
'.Value = GetText(strBody, "email:", "subject:")
.offset(0, 1).Value = GetText(strBody, "End Time:", ".Published")
.offset(0, 2).Value = GetText(strBody, "Server:", "Start Time:")
.offset(0, 3).Value = GetText(strBody, "Start Time:", "End Time:")
.offset(0, 4).Value = GetText(strBody, "End Time:", "M")
End With

'Save and close the file
wbTarget.Save
'Changed the code here
wbTarget.Close
'Release the workbook and application objects to free up memory
Set wbTarget = Nothing
Set xlApp = Nothing

End Sub

Function GetText(strBody As String, strStart As String, strEnd As String) As String
'returns a string of the text between two strings
'in a string to search (BAD explanation!)
'I am working this issue

Dim lngPos As Long
Dim tempString As String

lngPos = InStr(1, strBody, strStart)
tempString = Right(strBody, Len(strBody) - lngPos - Len(strStart) + 1)
lngPos = InStrRev(tempString, strEnd)
If strEnd = ".Published" Then
tempString = Left(tempString, lngPos - 1)
tempString = Right(tempString, lngPos - 33)
Else
tempString = Left(tempString, lngPos - 5)
End If
GetText = Trim(tempString)
End Function[/vba]

Now Here is what an example of the email I will be getting. The body of the will be in HTML format.


ADSS Sync Complete for the Following Project:
Server: xxxxx0xx11111

Start Time: 4/19/2006 7:10:36 AM
End Time: 4/19/2006 7:12:31 AM

• D0487 - (XXXX) Testing 5.Published <----Project name.

I need help with grabbing the End Time and the Project name (length of the name will vary) correctly.

Thanks

[Killian]

Jolly good.
Well I seem to remember mentioning that string parsing function wasn't very robust.
Here's some code changes that take a slighty different approach, splitting each line into an array, then finding the array item for each item and stripping the unwanted text out, returning the result.[VBA]'declared at module level (outside the routines)
Dim arrBody() As String

Sub ProcessMail2Excel() '...
'...
'instead of holding the text in a variable
'split it into an array
arrBody() = Split(myMailItem.Body, vbLf)

'...
.offset(0, 1).Value = GetText("Server:")
.offset(0, 2).Value = GetText("Start Time:")
.offset(0, 3).Value = GetText("End Time:")
.offset(0, 4).Value = GetText(".Published")
'...
End Sub

'###############################################
'function to return specified text result from array
Function GetText(strTarget As String) As String
Dim lngArrayIndex As Long
lngArrayIndex = FindArrIndex(strTarget)
If strTarget = ".Published" Then
GetText = Trim(Left(arrBody(lngArrayIndex), _
Len(arrBody(lngArrayIndex)) - Len(strTarget)))
Else
GetText = Trim(Right(arrBody(lngArrayIndex), _
Len(arrBody(lngArrayIndex)) - Len(strTarget)))
End If
End Function

'###############################################
'function to array index of specified string
Function FindArrIndex(str As String) As Long
For i = 0 To UBound(arrBody)
If InStr(1, arrBody(i), str) > 0 Then
FindArrIndex = i
Exit For
End If
Next i
End Function[/VBA]

[SeanJ]

The code works, but everything other than the ".Published" has a space at the end. I am trying to trim it, but I stink at VBA.

[SeanJ]

I got it to work the way I need it to, but I think it can be done differently. Your take on it.

[VBA]Function GetText(strTarget As String) As String
Dim lngArrayIndex As Long
lngArrayIndex = FindArrIndex(strTarget)
If strTarget = ".Published" Then
GetText = Trim(Left(arrBody(lngArrayIndex), _
Len(arrBody(lngArrayIndex)) - Len(strTarget) - 1))
Else
GetText = Trim(Right(arrBody(lngArrayIndex), Len(arrBody(lngArrayIndex)) - Len(strTarget)))
'new part that SeanJ added
count = Len(GetText)
count = count - 1
GetText = Left(GetText, count)

End If
End Function[/VBA]

[Killian]

I think the extra non-printing characters are linefeeds rather than spaces (wrapping the result in the Trim() function gets rid of any leading and trailing spaces).
I suppose to make a more robust function, we should test for it and take it off if it's there after the main If...Then...Else...[VBA]Function GetText(strTarget As String) As String
Dim lngArrayIndex As Long
lngArrayIndex = FindArrIndex(strTarget)
If strTarget = ".Published" Then
GetText = Trim(Left(arrBody(lngArrayIndex), _
Len(arrBody(lngArrayIndex)) - Len(strTarget)))
Else
GetText = Trim(Right(arrBody(lngArrayIndex), _
Len(arrBody(lngArrayIndex)) - Len(strTarget)))
End If
If Mid(GetText, Len(GetText), 1) = vbLf Then
GetText = Left(GetText, Len(GetText) - 1)
End If
End Function[/VBA]

[SeanJ]

I inserted the new code and I still get that space or return after the server name and Times.

[SeanJ]

Over the weekend I thinking about this process and decided to send the email body to an Access database.

Here is the code that I changed:
[VBA]Sub ProcessMail2Access(myMailItem As MailItem)
' exports data from an email to a table in an Access database
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
' connect to the Access database
arrBody() = Split(myMailItem.Body, vbLf)
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=d:\temp\emailstuff.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "emailtbl", cn, adOpenKeyset, adLockOptimistic, adCmdTable

With rs
.AddNew ' create a new record
' add values to each field in the record
.fields("longtitle") = GetText(".Published")
.fields("servername") = GetText("Server:")
.fields("starttime") = GetText("Start Time:")
.fields("endtime") = GetText("End Time:")
.Update ' stores the new record
End With

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub[/VBA]

[Killian]

Well I'd say thats a good idea, well executed.

[SeanJ]

Thank you for the help.

[geekgirlau]

Hi Sean,

I've marked your thread as "Solved" - let me know if I've jumped the gun here! Normally you can do this via the Thread Tools at the top of the page, but it's currently not working.

[SeanJ]

Thanks