email to excel problem

[mmenofy]

hi guys,

I am using the following code to save e-mails to an excel sheet, but I noticed that when e-mail comes while I am opening the excel sheet (any excel), it closes any opened excel and don't save (only saving the email tracking found in the VBA code)

please help

the code:
Sub ExportToExcelclient(MyMail As MailItem)
Dim strID As String, olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim strFileName As String
'~~> Excel Variables
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
DoEvents
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
DoEvents
'~~> Show Excel
oXLApp.Visible = False
'~~> Open the relevant file

Set oXLwb = oXLApp.Workbooks.Open("D:\E-MOVE\OUT-MAILS.xlsb")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("FROM-MAIL")
lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
'~~> Write to outlook
With oXLws
'
'~~> Code here to output data from email to Excel File
'~~> For example
'
.Range("A" & lRow).Value = olMail.Subject
' .Range("B" & lRow).Value = olMail.SenderName
.Range("B" & lRow).Value = olMail.ReceivedTime
.Range("C" & lRow).Value = olMail.Body
'
End With
'~~> Close and Clean up Excel
On Error Resume Next
oXLwb.Sheets("FROM-MAIL").ShowAllData
On Error GoTo 0
oXLwb.Close savechanges:=True
Set oXLwb = oXLApp.Workbooks.Open("D:\E-MOVE\OUT-MAILS.xlsb")
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub

 

[mmenofy]

Please support