I have the code below which takes about 25 mins to run, all it does is
extract sheets from another file and e-mails them out, it used to take
only 5-6 mins, I don't know why it has now exploded in time, I've even
turned calculations to manual, the file size of the source hasn't
increased in size, I've turned calculations on this to manual also.
Code ex Ron De Bruin. Anyone any suggestions. Could it be any virus, I
use AVG server, although have always used this even when it only took
5-6 mins

Sub Mail()
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim Sh As Worksheet
    Dim strbody As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook

    Application.Calculation = xlCalculationManual

    'Copy the sheets to a new workbook
    Sourcewb.Sheets(Array("Sales", "Hours", "Current", "PvL", "AvL",
"Comments", "Excess")).Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security
dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's
disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51

            End If
        End If
    End With

    '    'Change all cells in the worksheets to values if you want
    '    For Each sh In Destwb.Worksheets
    '        sh.Select
    '        With sh.UsedRange
    '            .Cells.Copy
    '            .Cells.PasteSpecial xlPasteValues
    '            .Cells(1).Select
    '        End With
    '        Application.CutCopyMode = False
    '        Destwb.Worksheets(1).Select
    '    Next sh

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-
mmm-yy h-mm") & "~"

    ActiveWindow.TabRatio = 0.908


    Sheets("Sales").Activate
    Range("A1").Select


    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)

    For Each cell In ThisWorkbook.Sheets("Current").Range("BF2:BF35")
    strbody = strbody & cell.Value & vbNewLine
    Next

    For Each cell In ThisWorkbook.Sheets("Current") _
    .Columns("BB").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next
    strto = Left(strto, Len(strto) - 1)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = strto
            .Subject =
ThisWorkbook.Sheets("Current").Range("BA1").Value
            .Body = strbody
            .Attachments.Add Destwb.FullName
            .ReadReceiptRequested = True
            If Sheets("Current").Range("D192").Value > 0 Then
            .Importance = 2
            Else
            .Importance = 1
            End If
            .SendUsingAccount = OutApp.Session.Accounts.Item(3)
            .Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Hi Seanie

Send me your workbook private and I try to reproduce it



-- 

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm



"Seanie" <seanryanie@yahoo.co.uk> wrote in message news:45fdbf68-57c8-4c9c-a09a-9ec0f662a6f1@g28g2000yqh.googlegroups.com...
> I have the code below which takes about 25 mins to run, all it does is
> extract sheets from another file and e-mails them out, it used to take
> only 5-6 mins, I don't know why it has now exploded in time, I've even
> turned calculations to manual, the file size of the source hasn't
> increased in size, I've turned calculations on this to manual also.
> Code ex Ron De Bruin. Anyone any suggestions. Could it be any virus, I
> use AVG server, although have always used this even when it only took
> 5-6 mins
> 
> Sub Mail()
>    Dim FileExtStr As String
>    Dim FileFormatNum As Long
>    Dim Sourcewb As Workbook
>    Dim Destwb As Workbook
>    Dim TempFilePath As String
>    Dim TempFileName As String
>    Dim OutApp As Outlook.Application
>    Dim OutMail As Outlook.MailItem
>    Dim Sh As Worksheet
>    Dim strbody As String
> 
>    With Application
>        .ScreenUpdating = False
>        .EnableEvents = False
>    End With
> 
>    Set Sourcewb = ActiveWorkbook
> 
>    Application.Calculation = xlCalculationManual
> 
>    'Copy the sheets to a new workbook
>    Sourcewb.Sheets(Array("Sales", "Hours", "Current", "PvL", "AvL",
> "Comments", "Excess")).Copy
>    Set Destwb = ActiveWorkbook
> 
>    'Determine the Excel version and file extension/format
>    With Destwb
>        If Val(Application.Version) < 12 Then
>            'You use Excel 97-2003
>            FileExtStr = ".xls": FileFormatNum = -4143
>        Else
>            'You use Excel 2007
>            'We exit the sub when your answer is NO in the security
> dialog that you only
>            'see  when you copy a sheet from a xlsm file with macro's
> disabled.
>            If Sourcewb.Name = .Name Then
>                With Application
>                    .ScreenUpdating = True
>                    .EnableEvents = True
>                End With
>                MsgBox "Your answer is NO in the security dialog"
>                Exit Sub
>            Else
>                FileExtStr = ".xlsx": FileFormatNum = 51
> 
>            End If
>        End If
>    End With
> 
>    '    'Change all cells in the worksheets to values if you want
>    '    For Each sh In Destwb.Worksheets
>    '        sh.Select
>    '        With sh.UsedRange
>    '            .Cells.Copy
>    '            .Cells.PasteSpecial xlPasteValues
>    '            .Cells(1).Select
>    '        End With
>    '        Application.CutCopyMode = False
>    '        Destwb.Worksheets(1).Select
>    '    Next sh
> 
>    'Save the new workbook/Mail it/Delete it
>    TempFilePath = Environ$("temp") & "\"
>    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-
> mmm-yy h-mm") & "~"
> 
>    ActiveWindow.TabRatio = 0.908
> 
> 
>    Sheets("Sales").Activate
>    Range("A1").Select
> 
> 
>    Set OutApp = CreateObject("Outlook.Application")
>    OutApp.Session.Logon
>    Set OutMail = OutApp.CreateItem(0)
> 
>    For Each cell In ThisWorkbook.Sheets("Current").Range("BF2:BF35")
>    strbody = strbody & cell.Value & vbNewLine
>    Next
> 
>    For Each cell In ThisWorkbook.Sheets("Current") _
>    .Columns("BB").Cells.SpecialCells(xlCellTypeConstants)
>        If cell.Value Like "?*@?*.?*" Then
>            strto = strto & cell.Value & ";"
>        End If
>    Next
>    strto = Left(strto, Len(strto) - 1)
> 
>    With Destwb
>        .SaveAs TempFilePath & TempFileName & FileExtStr,
> FileFormat:=FileFormatNum
>        On Error Resume Next
>        With OutMail
>            .To = ""
>            .CC = ""
>            .BCC = strto
>            .Subject =
> ThisWorkbook.Sheets("Current").Range("BA1").Value
>            .Body = strbody
>            .Attachments.Add Destwb.FullName
>            .ReadReceiptRequested = True
>            If Sheets("Current").Range("D192").Value > 0 Then
>            .Importance = 2
>            Else
>            .Importance = 1
>            End If
>            .SendUsingAccount = OutApp.Session.Accounts.Item(3)
>            .Send
>        End With
>        On Error GoTo 0
>        .Close savechanges:=False
>    End With
> 
>    'Delete the file you have send
>    Kill TempFilePath & TempFileName & FileExtStr
> 
>    Set OutMail = Nothing
>    Set OutApp = Nothing
> 
> End Sub
> 

there are two things that may be causing the probelm

1) Do you have a delay of around 45 seconds when you open any of the
Microsoft Produccts including excel.  the file system Indexing may have
been truned on which caused delays in opening excel.  I know how to fix
this problem.

2) Did you change anything on your PC like upgrade to Office 2008, or
changed from From XP to either Vista or windows 7?  Office 2008 is much
slower than 2003.  Microsft was working on some fixes.  so make sure you
have all the latest upgrades.

3) Your may have a memory problem on your PC or a hard disk Problem. 
Your hard Drive could be fragmented or running out of space.  run a
speed disk utility to fix the hard drive.  You may also be low on your
temp folder on your PC.  Delete any temp file you don't need and your
Waste Basket.


-- 
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=185339

[url="http://www.thecodecage.com/forumz/"]Excel Live Chat[/url]

On Mar 7, 11:03=A0am, "Ron de Bruin" <rondebr...@kabelfoon.nl> wrote:
> Hi Seanie
>
> Send me your workbook private and I try to reproduce it
>
> --
>
> Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm
>

Thanks Ron, its a fairly confidential file so I'll have to see if I
can extract safely first

On Mar 7, 11:06=A0am, joel <joel.47g...@thecodecage.com> wrote:
> there are two things that may be causing the probelm
>
> 1) Do you have a delay of around 45 seconds when you open any of the
> Microsoft Produccts including excel. =A0the file system Indexing may have
> been truned on which caused delays in opening excel. =A0I know how to fix
> this problem.
>
> 2) Did you change anything on your PC like upgrade to Office 2008, or
> changed from From XP to either Vista or windows 7? =A0Office 2008 is much
> slower than 2003. =A0Microsft was working on some fixes. =A0so make sure =
you
> have all the latest upgrades.
>
> 3) Your may have a memory problem on your PC or a hard disk Problem.
> Your hard Drive could be fragmented or running out of space. =A0run a
> speed disk utility to fix the hard drive. =A0You may also be low on your
> temp folder on your PC. =A0Delete any temp file you don't need and your
> Waste Basket.
>
> --
> joel

Thanks Joel

On (1) not 45 seconds everytime, but certainly sometimes, how can I
check the indexing

On (2) Running Office 2007 on Windows Server 2003, have all available
updates

On (3) How can I check the temp folder and then clear it? I run
Terminal Services, so all runs on the server, no hard disk space issue
on this (its just a recent new disk installed, but had the problem
prior, so can't see fragmentation the issue)

Check in the task manager for the following process:

Cidaemon.exe 

There are lots of webpages that tell you how to tunr off the Indexing
Service looking at google under

turn off indexing Service


Here is one site.

'How to Turn Off Windows Indexing Service in XP | Windows Reference'
(http://tinyurl.com/ydw6mrk)


-- 
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=185339

[url="http://www.thecodecage.com/forumz/"]Excel Live Chat[/url]