VBA problem with unsharing and re-sharing workbook

[unreasonable]

I am using Ron deBruins outlook macro to send an email from a spreadsheet, and for the most part, I have it working the way I want. The workbook is set up as a shared workbook, with the code below linked to a button. Basically what I am trying to get is, the button is pressed, the book unshares itself, then unprotects the sheet that needs to be copied into the body of the email, then reprotects itself, then reshares itself. It works perfectly except that sometimes when the book reshares itself, it saves in the wrong folder. I think it happens if the person has recently saved a different book in a different folder, then the macro tries to save this book into that same folder.

I have tried to fix this issue by making the book save itself before any of the other code executes (activeworkbook.save near the top), however this isn't working. I haven't specified what path to save the file when it re-shares itself becuase these files are named based on the date they are created and are located within monthly and yearly folders, so the location changes depending on the current date. Below is the code I am using. If anyone can help fix this annoying issue I would be greatly appreciative.

Sub Post_Mortem_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim rng2 As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    'Turns off screen updating
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    'If workbook is shared, unshares
   If ActiveWorkbook.MultiUserEditing Then
    ActiveWorkbook.ExclusiveAccess
    End If
   
   'unprotects worksheet with password
   Sheet6.Unprotect ("password")
   
    Set rng = Nothing
    Set rng2 = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Range("C17:M79").SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = Range("C9")
        .CC = Range("C15")
        .BCC = ""
        .Subject = "something " & Date - 1
        .HTMLBody = RangetoHTML(rng)
        .Attachments.Add ActiveWorkbook.FullName
        .Display   'use .Display or .Send
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = False
    End With
    'protects sheet with password  and allows formatting of rows
    Sheet6.Protect ("password"), AllowFormattingRows:=True
    'shares workbook again
    ActiveWorkbook.SaveAs , , , , , , xlShared
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    rng.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

 

[RoryA]

Why not use activeworkbook.fullname in the saveas line?

 

[unreasonable]

I didn't think it was necessary since the file always saves as the proper name, just not always in the correct location. Do you think that will fix the issue?

 

[RoryA]

Since FullName includes the path, it should do.

 

[unreasonable]

So just

 ActiveWorkbook.SaveAs (ActiveWorkbook.FullName), , , , , , xlShared

at the bottom instead of ActiveWorkbook.SaveAs , , , , , xlShared?? That's simple enough to at least try. Thanks so much :D

Edit: It is making a Backup file in the saveas path, so instead of being "unreasonable 6-7-11", it is saving as "Backup of unreasonable 6-7-11.xlk".

 

[unreasonable]

It looks like it is saving over the old file as well as creating a backup. I think I need to make a few other modifications to the savas line, I'll reply back if Google helps me solve the issue.

 

[RoryA]

It's supposed to save over the old file is it not, since you are merely trying to make it shared again?

 

[unreasonable]

It's supposed to save over the old file is it not, since you are merely trying to make it shared again?

Yes, but it wasn't supposed to also make a backup file, which it was. The previous code left that part of the statement blank, I just changed it to FALSE and now it appears to be working correctly. Thanks again for your help!