Strange delay in execution of MailTo Macro code

[tnuis]

Hello, The following code takes ages to run. It gets quickly to the point where it opens a New EMPTY email and then the users have to wait for about 4-5 minutes before the rest of the code finally executes. Anybody have any tips as how to speed things up? It would be much appreciated. It seems to me that it is getting stuck at the point "'*****save as pdf ". Almost as if the Publishing of the pdf´s takes a loooong time to start. And, all users use Office 2010.

Sub Mailto_Click()
  Dim OutApp As Object
     Dim OutMail As Object
     Dim Signature As String
     Dim FullPath As String
     
     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)
     
 If Sheet1.Visible = xlSheetVisible Then
     Sheet1.Visible = xlSheetHidden
 End If
 If Sheet2.Visible = xlSheetVisible Then
     Sheet2.Visible = xlSheetHidden
 End If
 If Sheet5.Visible = xlSheetVisible Then
     Sheet5.Visible = xlSheetHidden
 End If
 If Ark6.Visible = xlSheetVisible Then
     Ark6.Visible = xlSheetHidden
 End If
     With OutMail
     .Display
     End With
         Signature = OutMail.htmlbody
     Dim ws As Worksheet    
 '*****save as pdf        
 For Each ws In Sheets
 If ws.Visible = True Then
 FullPath = ThisWorkbook.Path & "\" & ws.Name & ".PDF"
     
     ws.ExportAsFixedFormat _
       Type:=xlTypePDF, _
       Filename:=FullPath
       End If
 Next
 '********
     On Error Resume Next
     With OutMail
         .To = Range("D10").Value
         .CC = ""
         .BCC = ""
         .Subject = "Papirer Bestilling"
         .htmlbody = "Sampletext" & Signature
 '****add as attachements
 For Each ws In Sheets
 If ws.Visible = True Then
 FullPath = ThisWorkbook.Path & "\" & ws.Name & ".PDF"
         .Attachments.Add FullPath
  End If
  Next
 Sheet1.Visible = xlSheetVisible
 If Sheet1.ComboBox3.Value = "Leie" Then
     Ark6.Visible = xlSheetVisible
     Sheet5.Visible = xlSheetVisible
 End If
 If Sheet1.ComboBox3.Value = "Leasing" Then
     Ark6.Visible = xlSheetVisible
     Sheet5.Visible = xlSheetVisible
 End If
    
 Sheet1.Activate
 '********
         .Display
     End With
     On Error GoTo 0
     Set OutMail = Nothing
     Set OutApp = Nothing
     

 End Sub

[Kenneth Hobs]

If you had Outlook open already, and used GetObject() rather than CreateObject() that might speed things. DoEvents may help on occassion. http://answers.microsoft.com/en-us/o...0-95a9680000f8

Creation of the PDFs may be taking longer than you think. Try using a timer to see time for tasks.

From a blank sheet run

Sub FillARange()
  Dim r As Range, bRange As Range, t1 As Double
  Cells.ClearContents
  t1 = Timer
  SpeedOn
  [A1] = "ColA"
  [B1] = "ColB"
  [C1] = "ColC"
  Set bRange = Range("A2:C1000")
  For Each r In bRange
    If r.Column = 1 And r.Row Mod 2 = 0 Then
      r.Value = "Delete"
      Else: r.formula = "=Row()*Column()"
    End If
  Next r
  SpeedOff
  MsgBox "Added " & bRange.Rows.Count & " rows and " & bRange.Count & " cells." & _
  vbCrLf & "It took " & CStr(Timer - t1) & " seconds."
End Sub

[tnuis]

Hmmm.... When I run the code in a blank sheet I get error Message: Compile Error: Sub or Function not defined. And the debug is highlighting "SpeedOn" as yellow.

Also GetObject() doesn´t seem to make any noticeable difference since Outlook is always open anyway. I´m pretty sure that the problem lies AFTER this since this pops up instantly, but then it will stay blank until code is finished running.

There are 2 Things that I think are interesting though, 1. When I use another macrobutton "SaveAsPDF" (not in Outlook, just to you desktop for example) then it creates the PDF´s in a heartbeat. It is my understanding that it´s the same PDF convertion function that is used. Also point 2. I found that if I let my original code run for 4 minutes till it´s done and then Close the mail and instantly hit the macro button "MailTo" again then it runs in less than 10 Seconds. If I Close the excelprogram and reopen the first time always takes 4-5 minutes for the MailTo code to run. It takes quite a while for the msgbox to popup showing that it´s Publishing the files one by one. For each visible sheet it needs a lot of time to start Publishing.

My best Guess would be that the problem lies in the following part of the code:
[CODE][For Each ws In Sheets
If ws.Visible = True Then
FullPath = ThisWorkbook.Path & "\" & ws.Name & ".PDF"

ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FullPath
End If
Next/CODE]

Any other suggestions?

[Kenneth Hobs]

Obviously, you would need the Speedon routine installed for it to work.

Use the Timer to time how long each PDF takes to create. Use Debug.print to show the results of timer after each file is created. Use DoEvents as I explained.

Because you get a message does not mean that all things were completed.

[SamT]

The Signature + htmlBody Assignment is the problem. Do the commented) Signature assignment in this code and see if it fixes your speed issue.

Option Explicit

Sub Mailto_Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Signature As String
    Dim FullPath As String
    Dim ws As Worksheet
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    'Signature = OutMail.htmlbody 'Resolution problem
     
    Application.ScreenUpdating = False
    Sheet1.Visible = xlSheetHidden
    Sheet2.Visible = xlSheetHidden
    Sheet5.Visible = xlSheetHidden
    Ark6.Visible = xlSheetHidden
    
    With OutMail
        '.Display
        .To = Range("D10").Value
        .CC = ""
        .BCC = ""
        .Subject = "Papirer Bestilling"
        .htmlbody = "Sampletext" & Signature
     '*****save as pdf
        For Each ws In Sheets
            If ws.Visible = True Then
                FullPath = ThisWorkbook.Path & "\" & ws.Name & ".PDF"
                ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FullPath
         '****add as attachements
                OutMail.Attachments.Add FullPath
           End If
        Next
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    '********
    On Error Resume Next
    With Sheet1
        .Visible = xlSheetVisible
        With .ComboBox3
          If .Value = "Leie" Or .Value = "Leasing" Then
              Ark6.Visible = xlSheetVisible
              Sheet5.Visible = xlSheetVisible
              'Sheet2 ???
          End If
        End With
        .Activate
         '********
    End With

Application.ScreenUpdating = True
OutMail.Display
End Sub