ExportToExcel VBA

mmenofy

New Member
Joined
Apr 30, 2019
Messages
12
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
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
525
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
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...

VBA Code:
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

New Member
Joined
Apr 30, 2019
Messages
12
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...

VBA Code:
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

New Member
Joined
Apr 30, 2019
Messages
12

ADVERTISEMENT

I tried your code, but I got an error
 

Attachments

  • CODE.jpg
    CODE.jpg
    93.5 KB · Views: 7

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
525
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Perhaps this....
VBA Code:
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

New Member
Joined
Apr 30, 2019
Messages
12

ADVERTISEMENT

Perhaps this....
VBA Code:
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

Well-known Member
Joined
Oct 9, 2015
Messages
525
Office Version
  1. 365
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Could always try ActiveWorkbook.Close savechanges:=True providing it is the active book
 

mmenofy

New Member
Joined
Apr 30, 2019
Messages
12
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
 

Watch MrExcel Video

Forum statistics

Threads
1,127,210
Messages
5,623,405
Members
415,972
Latest member
SY1234

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top