ExportToExcel VBA

[mmenofy]

Hi,
I've used the following VBA (ExportToExcel) to export mails into excel sheet in order to track it easily, but when I received the mail, and the vba is running, the excel freezes for seconds (sometimes 2 minutes), but at the end it works, I dealt with this years ago , but I am asking if there is any solution to avoid that freezing specially it also freezes any other opened excel sheets

The used VBA:

Sub ExportToExcel(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")
'~~> 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
'~~> Show Excel
oXLApp.Visible = False
'~~> Open the relevant file
Set oXLwb = oXLApp.Workbooks.Open("E:\MAIL FOLLOWUP\MAIL-FOLLOWUP-2020.xlsx")
'~~> Set the relevant output sheet. Change as applicable
Set oXLws = oXLwb.Sheets("STEP-1")
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("C" & lRow).Value = olMail.ReceivedTime
'
End With
'~~> Close and Clean up Excel
oXLwb.Close (True)
oXLApp.Quit
Set oXLws = Nothing
Set oXLwb = Nothing
Set oXLApp = Nothing
Set olMail = Nothing
Set olNS = Nothing
End Sub


EDIT
Also Outlook freezes not only excel

 

[mmenofy]

anybody there ??

 

[decadence]

It looks like you are not releasing the memory of the Excel and Outlook Applications before quitting Excel and is saving with the stored memory.

Code below Untested...

Option Explicit
Dim strID As String, olNS As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strFileName As String
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long

Sub ExportToExcel(MyMail As MailItem)

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oXLApp.Visible = False
    Set oXLwb = oXLApp.Workbooks.Open("E:\MAIL FOLLOWUP\MAIL-FOLLOWUP-2020.xlsx")
    Set oXLws = oXLwb.Sheets("STEP-1")
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).row + 1

    With oXLws
        .Range("A" & lRow).Value = olMail.Subject
        .Range("B" & lRow).Value = olMail.SenderName
        .Range("C" & lRow).Value = olMail.ReceivedTime
    End With

    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Workbooks("MAIL-FOLLOWUP-2020.xlsx").Close (True)
    Application.Quit

End Sub

 

[mmenofy]

It looks like you are not releasing the memory of the Excel and Outlook Applications before quitting Excel and is saving with the stored memory.

Code below Untested...

Option Explicit
Dim strID As String, olNS As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strFileName As String
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long

Sub ExportToExcel(MyMail As MailItem)

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oXLApp.Visible = False
    Set oXLwb = oXLApp.Workbooks.Open("E:\MAIL FOLLOWUP\MAIL-FOLLOWUP-2020.xlsx")
    Set oXLws = oXLwb.Sheets("STEP-1")
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).row + 1

    With oXLws
        .Range("A" & lRow).Value = olMail.Subject
        .Range("B" & lRow).Value = olMail.SenderName
        .Range("C" & lRow).Value = olMail.ReceivedTime
    End With

    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Workbooks("MAIL-FOLLOWUP-2020.xlsx").Close (True)
    Application.Quit

End Sub

Thank you so much, I think you are right, i will try the code the inform you

 

[mmenofy]

I tried your code, but I got an error

 

[decadence]

Perhaps this....

Option Explicit
Dim strID As String, olNS As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strFileName As String
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long

Sub ExportToExcel(MyMail As MailItem)

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oXLApp.Visible = False
    Set oXLwb = oXLApp.Workbooks.Open("E:\MAIL FOLLOWUP\MAIL-FOLLOWUP-2020.xlsx")
    Set oXLws = oXLwb.Sheets("STEP-1")
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).row + 1

    With oXLws
        .Range("A" & lRow).Value = olMail.Subject
        .Range("B" & lRow).Value = olMail.SenderName
        .Range("C" & lRow).Value = olMail.ReceivedTime
    End With

    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Workbooks("MAIL-FOLLOWUP-2020.xlsx").Close savechanges:=True
    Application.Quit

End Sub

 

[mmenofy]

Perhaps this....

Option Explicit
Dim strID As String, olNS As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strFileName As String
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim lRow As Long

Sub ExportToExcel(MyMail As MailItem)

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    oXLApp.Visible = False
    Set oXLwb = oXLApp.Workbooks.Open("E:\MAIL FOLLOWUP\MAIL-FOLLOWUP-2020.xlsx")
    Set oXLws = oXLwb.Sheets("STEP-1")
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).row + 1

    With oXLws
        .Range("A" & lRow).Value = olMail.Subject
        .Range("B" & lRow).Value = olMail.SenderName
        .Range("C" & lRow).Value = olMail.ReceivedTime
    End With

    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    Workbooks("MAIL-FOLLOWUP-2020.xlsx").Close savechanges:=True
    Application.Quit

End Sub

Many Thanks for your efforts, but Same Error

 

[decadence]

Could always try ActiveWorkbook.Close savechanges:=True providing it is the active book

 

[mmenofy]

Could always try ActiveWorkbook.Close savechanges:=True providing it is the active book

It didn't work , ( may be the reason is the size of excel sheet !!! [3,5 MB] )

 

[mmenofy]

I reduced the file size (to be 300 KB), removing all sheets inside, keeping only the outlook pool, then tried, everything goes very well (Hanging only 2-3 seconds)
I think the problem was the file size Only

Thank you so much