Macro stops working

[G2K]

Hi All,

i have designed a excel sheet to collect data from our stake holders.the user need to fill the data in this spreadsheet and press a Button 'Save and Send' to send it to my ID.I have tested the spreadsheet and it works perfectly. However, as soon as I load it onto our intranet site……..the error message appears when I try to ‘save & send’ . I have no idea why this happens.all other spreadsheet which have same button and are online seem to work perfectly so I don’t understand why this doesn’t work.

Code:-

Private Sub Saveandsend()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim Wb As Workbook
    Dim NewWb As Workbook
    Dim Ws As Worksheet
    Dim wRng As Range
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableCancelKey = xlDisabled
    End With
 
 
     'Create Excel sheet  link
    Set Wb = ActiveWorkbook
    Set wRng = Sheets("Sheet1").Range("B4:H42").SpecialCells(xlCellTypeVisible)
 
'Create link to Excel sheet
     Wb.SaveAs Range("D18").Value & "_" & Range("G19").Value
 
     'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")
 
     'Create Mail Item and send it
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
    .To = "[EMAIL="abc@xyz.com"]abc@xyz.com[/EMAIL]"
    .cc = "[EMAIL="abc@xyz.com"]abc@xyz.com[/EMAIL]"
    .Subject = "Product Penetration Lead Slip_" & Sheet1.Range("D18").Value & "_" & Sheet1.Range("D19").Value & "_" & Sheet1.Range("G18").Value & "_" & Sheet1.Range("G19").Value
    .HTMLBody = RangetoHTML(wRng)
    .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
    .display
      End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableCancelKey = xlErrorHandler
    End With
  End Sub 
 
 
Function RangetoHTML(wRng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    'Range("A1:G20").Select
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    wRng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Any help would be appriciated.

Many thanks

 

[AlphaFrog]

What does the error message say?

 

[G2K]

the first error was - "A file named Filename.xls is already exist, do you want to replace it" when user press yes, it works,if he press No, a error appears -Method Saveas of object Class failed, However i fixed it by using application.DisplayAlerts but now this is througing up an error - Method 'DisplayAlerts' of object '_Application' Failed

Thanks

 

[nightcrawler23]

the first error was - "A file named Filename.xls is already exist, do you want to replace it" when user press yes, it works,if he press No, a error appears -Method Saveas of object Class failed, However i fixed it by using application.DisplayAlerts but now this is througing up an error - Method 'DisplayAlerts' of object '_Application' Failed

Thanks

Private Sub Saveandsend()
    Dim OutlookApp As Object
    Dim MItem As Object
    Dim Wb As Workbook
    Dim NewWb As Workbook
    Dim Ws As Worksheet
    Dim wRng As Range
    
[COLOR=red]    On Error GoTo errcheck[/COLOR]
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableCancelKey = xlDisabled
    End With
 
 
     'Create Excel sheet  link
    Set Wb = ActiveWorkbook
    Set wRng = Sheets("Sheet1").Range("B4:H42").SpecialCells(xlCellTypeVisible)
 
'Create link to Excel sheet
     Wb.SaveAs Range("D18").Value & "_" & Range("G19").Value
 
     'Create Outlook object
    Set OutlookApp = CreateObject("Outlook.Application")
 
     'Create Mail Item and send it
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
    .To = "[EMAIL="abc@xyz.com"]abc@xyz.com[/EMAIL]"
    .cc = "[EMAIL="abc@xyz.com"]abc@xyz.com[/EMAIL]"
    .Subject = "Product Penetration Lead Slip_" & Sheet1.Range("D18").Value & "_" & Sheet1.Range("D19").Value & "_" & Sheet1.Range("G18").Value & "_" & Sheet1.Range("G19").Value
    .HTMLBody = RangetoHTML(wRng)
    .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
    .display
      End With
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableCancelKey = xlErrorHandler
    End With
[COLOR=red]    
errcheck:[/COLOR]
End Sub

try adding the lines in red
the macro should exit on any error...

 

[G2K]

Thanks nightcrawler23 for your reply,but i think this is not going to help. i do not want to exit on any error.i can use error handler to supress the errorlike 'On error resume next' before the lines which are causing problem but it would defeat the main purpose i think.

i want to handle this error in such a way that i can get desired output.

thanks for your help