flickering/slow outlook VBA code

[Nichole09]

Hello All,

I have some code that finally works as needed however now the only issue is ....its slow. In the paste my code would only work some of the time due to, as I discovered, range b13:c21 would not always copy to the clipboard. With the error handler it does, yet takes 15 seconds+ to finally paste to the body of the email. I noticed when I click in the body of the email it appears a bit quicker then simply waiting for the code to execute. I have been searching for some time on how to make this quicker, and have found using Application.ScreenUpdating = False, Application.Calculation = xlCalculationManual and Application.EnableEvents = False should help, but for me it doesn't seem to make a difference. Any ideas? I appreciate all your help!!! This forum has really helped me learn about excel.

code:

Sub email()
Application.ScreenUpdating = False
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
MsgBox "Outlook is not open, open Outlook and try again"
Else
Call CopyAndPasteToMailBody
End If
Application.ScreenUpdating = True
End Sub

Sub CopyAndPasteToMailBody()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim mailapp As Object
Dim Mail As Object
Dim mysubject As String

mysubject = Worksheets("sheet1").Range("B10").value

Set mailapp = CreateObject("Outlook.Application")
Set Mail = mailapp.CreateItem(olMailItem)
Mail.display
Set wEditor = mailapp.ActiveInspector.wordEditor
pg1copyattempt:
DoEvents
ActiveSheet.Range("B13:C21").Copy
On Error GoTo pg1pastefail
wEditor.Application.Selection.paste
On Error GoTo 0
On Error Resume Next
With Mail
.To = "me@me.com"
.CC = ""
.BCC = ""
.Subject = mysubject
.display
End With

Exit Sub

pg1pastefail:
If Err.Number = 4605 Then
DoEvents
Resume pg1copyattempt
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

 

[hiker95]

Nichole09,

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Try adding the bold line of code to your macro:

ActiveSheet.Range("B13:C21").Copy
On Error GoTo pg1pastefail
wEditor.Application.Selection.paste

Application.CutCopyMode = False

On Error GoTo 0

 

[Macropod]

At least part of the problem with your code is that you're trying to instantiate Outlook twice, using different variable names. Try something along the lines of:

Sub CreateEmail()
'Note: This code requires references to Outlook and Word, via Tools|References
Application.ScreenUpdating = False
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet, StrSubj As String
Set xlWkSht = Worksheets("Sheet1")
StrSubj = xlWkSht.Range("B10").Value
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
  Else
    With olApp
      Set olMail = .CreateItem(olMailItem)
      olMail.Display
      Set olInsp = olMail.GetInspector
      Set wdDoc = olInsp.WordEditor
      Set wdRng = wdDoc.Range
      xlWkSht.Range("B13:C21").Copy
      wdRng.Paste
      With olMail
        .To = "me@me.com"
        .CC = ""
        .BCC = ""
        .Subject = StrSubj
        .Display
      End With
    End With
  End If
End If
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Nichole09]

Hello!! Thank you for your quick response. I tried your code below but it is highlighting the DIM section. When I try changing the dim from olapp to object just to see if this corrects the issue it highlights each DIM in this code and I receive this error: user-defined type not defined

Sub CreateEmail()
'Note: This code requires references to Outlook and Word, via Tools|References
Application.ScreenUpdating = False
[B]Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet, StrSubj As String[/B]
Set xlWkSht = Worksheets("Sheet1")
StrSubj = xlWkSht.Range("B10").Value
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
  Else
    With olApp
      Set olMail = .CreateItem(olMailItem)
      olMail.Display
      Set olInsp = olMail.GetInspector
      Set wdDoc = olInsp.WordEditor
      Set wdRng = wdDoc.Range
      xlWkSht.Range("B13:C21").Copy
      wdRng.Paste
      With olMail
        .To = "me@me.com"
        .CC = ""
        .BCC = ""
        .Subject = StrSubj
        .Display
      End With
    End With
  End If
End If
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

[/QUOTE]

 

[Macropod]

Did you read the first line in the code?

 

[Nichole09]

Macropod im sorry i didn't actually take the action of reference but i have completed this step now. However now when i run the macro it doesn't even pull up outlook or copy the range. What am i doing wrong? I copied and pasted this code. Perhaps i referenced the incorrect items? I am not certain how.

 

[Macropod]

Apologies - as posted the previous version worked only if Outlook wasn't already running. Try it this way:

Sub CreateEmail()
'Note: This code requires references to Outlook and Word, via Tools|References
Application.ScreenUpdating = False
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet, StrSubj As String
Set xlWkSht = Worksheets("Sheet1")
StrSubj = xlWkSht.Range("B10").Value
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
    GoTo ErrExit
  End If
End If
With olApp
  Set olMail = .CreateItem(olMailItem)
  olMail.Display
  Set olInsp = olMail.GetInspector
  Set wdDoc = olInsp.WordEditor
  Set wdRng = wdDoc.Range
  xlWkSht.Range("B13:C21").Copy
  wdRng.Paste
  With olMail
    .To = "me@me.com"
    .CC = ""
    .BCC = ""
    .Subject = StrSubj
    .Display
  End With
End With
ErrExit:
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Nichole09]

Apologies - as posted the previous version worked only if Outlook wasn't already running. Try it this way:

Sub CreateEmail()
'Note: This code requires references to Outlook and Word, via Tools|References
Application.ScreenUpdating = False
Dim olApp As Outlook.Application, olMail As Outlook.MailItem, olInsp As Outlook.Inspector
Dim wdDoc As Word.Document, wdRng As Word.Range, xlWkSht As Worksheet, StrSubj As String
Set xlWkSht = Worksheets("Sheet1")
StrSubj = xlWkSht.Range("B10").Value
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
  Set olApp = CreateObject("Outlook.Application")
  On Error GoTo 0
  If olApp Is Nothing Then
    MsgBox "Can't start Outlook.", vbExclamation
    GoTo ErrExit
  End If
End If
With olApp
  Set olMail = .CreateItem(olMailItem)
  olMail.Display
  Set olInsp = olMail.GetInspector
  Set wdDoc = olInsp.WordEditor
  Set wdRng = wdDoc.Range
  xlWkSht.Range("B13:C21").Copy
  wdRng.Paste
  With olMail
    .To = "me@me.com"
    .CC = ""
    .BCC = ""
    .Subject = StrSubj
    .Display
  End With
End With
ErrExit:
Set xlWkSht = Nothing: Set wdRng = Nothing: Set wdDoc = Nothing
Set olInsp = Nothing: Set olMail = Nothing: Set olApp = Nothing
Application.ScreenUpdating = True
End Sub

Awesome!! Thank you so much! This works!! IS there any possible way to ensure the default signature is added? I assume this line olmail.display would do the trick but its not pulling up.... ?

 

[Macropod]

The .Display method is fairly old and is only retained for backwards compatibility. Perhaps the .Activate method will do what you want; otherwise you might need to add code to insert the default signature by some other method. I haven't used Outlook much.