I am trying to create a macro that, upon save, asks the user if the file they are working is the final version. If it is, I would like to save a copy of that file in a different destination. It also creates an indicator with the username and date saved of the final copy so that if a user tries to create ANOTHER final copy, it asks them if they would like to overwrite the version created by [username] on [date].
I decided to use AfterSave as opposed to BeforeSave, as I would like the user to have the option of choosing between Save and SaveAs before the macro runs.
The issue that I am having is that if the user indicates that it is the final version, a copy is saved, triggering the AfterSave event. Is there a line of code I can add that would stop the AfterSave event after the file copy is saved?
Here is my current code.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
If Success Then
Call YesNoMessageBox
End If
End Sub
'Saves copy of tool if final version
Sub YesNoMessageBox()
Dim Answer1 As String
Dim MyNote1 As String
Dim fileName As String
Dim dlgOpen As FileDialog
Dim MyYear
Dim FilePath
Dim Answer2 As String
Dim MyNote2 As String
MyNote1 = "Is this the FINAL version?"
'Display MessageBox
Answer1 = MsgBox(MyNote1, vbQuestion + vbYesNo, "???")
If Answer1 = vbYes Then
If Not Worksheets("Data Input").Range("M2") = vbNullString Then
MyNote2 = "There is already a version saved by " & Worksheets("Data Input").Range("M2") & " on " & Worksheets("Data Input").Range("M3") & "." & vbNewLine & "Would you like to overwrite it?"
Answer2 = MsgBox(MyNote2, vbQuestion + vbYesNo, "???")
If Answer2 = vbYes Then
strUName = CreateObject("WScript.Network").UserName
Worksheets("Data Input").Range("M2") = strUName
Worksheets("Data Input").Range("M3") = Date
'Saves copy of tool in [folder name] folder
MyYear = Year(Worksheets("Data Input").Range("D13"))
ThisWorkbook.SaveAs fileName:="G:\[file path]" & Worksheets("Data Input").Range("D9") & " - " & Worksheets("Data Input").Range("D7") & " " & MyYear & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "Copy of tool saved in" & Application.ThisWorkbook.Path
End If
Else
strUName = CreateObject("WScript.Network").UserName
Worksheets("Data Input").Range("M2") = strUName
Worksheets("Data Input").Range("M3") = Date
'Saves copy of tool in [folder name]folder
MyYear = Year(Worksheets("Data Input").Range("D13"))
ThisWorkbook.SaveAs fileName:="G:\[File Path]\" & Worksheets("Data Input").Range("D9") & " - " & Worksheets("Data Input").Range("D7") & " " & MyYear & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "Copy of tool saved in" & Application.ThisWorkbook.Path
End If
End If
End Sub
Disable events before the SaveAs but don't forget to enable again after:
Application.EnableEvents = False
ThisWorkbook.SaveAs fileName:="G:\[File Path]\" & Worksheets("Data Input").Range("D9") & " - " & Worksheets("Data Input").Range("D7") & " " & MyYear & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
Related
I have some code that copys and pastes the current worksheet to a blank new workbook, and then saves it depending on the values of some cells (stored in variables).
Specifically, these are Site, Client, and Date visited.
It all works fine with site and client, however when I include the date variable in the filename to save, it throws an error: Runtime error 76 - Path not found.
I'd appreciate any help/advise.
Sub Pastefile()
Dim client As String
Dim site As String
Dim visitdate As String
client = Range("B3").Value
site = Range("B23").Value
screeningdate = Range("B7").Value
Dim SrceFile
Dim DestFile
SrceFile = "C:\2013 Recieved Schedules\schedule template.xlsx"
DestFile = "C:\2013 Recieved Schedules" & "\" & client & " " & site & " " & visitdate & ".xlsx"
FileCopy SrceFile, DestFile
ActiveWindow.SmallScroll Down:=-12
Range("A1:I37").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=-30
Workbooks.Open Filename:= _
"C:\Schedules\2013 Recieved Schedules" & "\" & client & " " & site & " " & visitdate & ".xlsx", UpdateLinks:= _
0
Range("A1:I37").PasteSpecial Paste:=xlPasteValues
Range("C6").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
When using dates in file names, you never want to rely on the default textual representation of the date, because that depends on the current locale.
You should store the date as date in the first place, and explicitly format it in a safe way for the file name:
Dim visitdate As Date
visitdate = Range("b7").Value
dim visitdate_text as string
visitdate_text = Format$(visitdate, "yyyy\-mm\-dd")
You might also consider removing any special characters like \ from your other values, such as client and site. Otherwise the problem might arise again.
Here is my suggestion of code rewrite:
Sub Pastefile()
Dim client As String
Dim site As String
Dim visitdate As String
client = Range("B3").Value
site = Range("B23").Value
visitdate = Range("B7").Value
Dim SrceFile
Dim DestFile
If IsDate(visitdate) Then
SrceFile = "C:\2013 Received Schedules\schedule template.xlsx"
DestFile = "C:\2013 Received Schedules" & "\" & Trim(client) & " " & Trim(site) & " " & Str(Format(Now(), "yyyymmdd")) & ".xlsx"
If Trim(Dir("C:\2013 Received Schedules\schedule template.xlsx")) <> "" Then
FileCopy SrceFile, DestFile
Else
MsgBox (SrceFile & " is not available in the folder")
GoTo EndCode
End If
Range("A1:I37").Select
Selection.Copy
Workbooks.Open Filename:= _
"C:\Schedules\2013 Received Schedules" & "\" & client & " " & site & " " & visitdate & ".xlsx", UpdateLinks:= 0
Range("A1:I37").PasteSpecial Paste:=xlPasteValues
Range("C6").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Else
MsgBox ("Please input the correct date in cell B7")
ActiveSheet.Range("B7").Activate
End If
EndCode:
End Sub
I'm trying to create auto installer that allows the user to open it and install the add-in automatically but i run in some problems during this.
One problem has to do with the extension of the file for some reason it allows the .xla but not the .xlam if I leave it as .xla it gives me that the file is corrupt every time I open a workbook second problem when I try the .xlam it doesn't allow me to install it error 1004 unable to get add property form the Addins class.
Any help will be appreciated.
ThisWorkbook
Option Explicit
'
'---------------------------------------------------------------------
' Purpose : Call for installation as an addin if not installed
'---------------------------------------------------------------------
'
Private Sub Workbook_Open()
Dim AddinTitle As String, AddinName As String
Dim XlsName As String
AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
XlsName = AddinTitle & ".xlsm"
AddinName = AddinTitle & ".xla"
'check the addin's not already installed in UserLibraryPath
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
'ask if user wants to install now
If MsgBox("Install " & AddinTitle & _
" as an add-in?", vbYesNo, _
"Install?") = vbYes _
Then
Run "InstallAddIn"
End If
Else
If ThisWorkbook.Name = XlsName Then
Run "ReInstall"
End If
End If
End Sub
'
'---------------------------------------------------------------------
' Purpose : Actuate the addin, add custom controls
'---------------------------------------------------------------------
'
Private Sub Workbook_AddinInstall()
Run "AddButtons"
End Sub
'
'---------------------------------------------------------------------
' Purpose : Deactivate the addin, remove custom controls
'---------------------------------------------------------------------
'
Private Sub Workbook_AddinUninstall()
Run "RemoveButtons"
End Sub
Module
Option Explicit
'
'---------------------------------------------------------------------
' Purpose : Convert .xls file to .xla, move it to
' addins folder, and install as addin
'---------------------------------------------------------------------
'
Private Sub InstallAddIn()
Dim AddinTitle As String, AddinName As String
Dim XlsVersion As String, MessageBody As String
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
AddinName = AddinTitle & ".xlam"
XlsVersion = .FullName '< could be anywhere
'check the addin's not installed in
'UserLibraryPath (error handling)
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
.IsAddin = True '< hide workbook window
'move & save as .xla file
.SaveAs Application.UserLibraryPath & AddinName
'go thru the add-ins collection to see if it's listed
If Listed Then
'check this addins checkbox in the addin dialog box
AddIns(AddinTitle).Installed = True '<--Error happening if .xlam format
Else
'it's not listed (not previously installed)
'add it to the addins collection
'and check this addins checkbox
AddIns.Add(ThisWorkbook.FullName, True) _
.Installed = True
End If
Kill XlsVersion '< delete .xls version
'inform user...
MessageBody = AddinTitle & " has been installed - " & _
"to access the tools available in" & _
vbNewLine & _
"this addin, you will find a button in the 'Tools' " & _
"menu for your use"
If BooksAreOpen Then '< quit if no other books are open
.Save
MsgBox MessageBody & "...", , AddinTitle & _
" Installation Status..."
Else
If MsgBox(MessageBody & " the" & vbNewLine & _
"next time you open Excel." & _
"" & vbNewLine & vbNewLine & _
"Quit Excel?...", vbYesNo, _
AddinTitle & " Installation Status...") = vbYes Then
Application.Quit
Else
.Save
End If
End If
End If
End With
End Sub
'---------------------------------------------------------------------
' Purpose : Checks if this addin is in the addin collection
'---------------------------------------------------------------------
'
Private Function Listed() As Boolean
Dim Addin As Addin, AddinTitle As String
Listed = False
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
For Each Addin In AddIns
If Addin.Title = AddinTitle Then
Listed = True
Exit For
End If
Next
End With
End Function
'---------------------------------------------------------------------
' Purpose : Check if any workbooks are open
' (this workbook & startups excepted)
'---------------------------------------------------------------------
'
Private Function BooksAreOpen() As Boolean
'
Dim Wb As Workbook, OpenBooks As String
'get a list of open books
For Each Wb In Workbooks
With Wb
If Not (.Name = ThisWorkbook.Name _
Or .Path = Application.StartupPath) Then
OpenBooks = OpenBooks & .Name
End If
End With
Next
If OpenBooks = Empty Then
BooksAreOpen = False
Else
BooksAreOpen = True
End If
End Function
'---------------------------------------------------------------------
' Purpose : Replace addin with another version if installed
'---------------------------------------------------------------------
'
Private Sub ReInstall()
Dim AddinName As String
With ThisWorkbook
AddinName = Left(.Name, Len(.Name) - 4) & ".xla"
'check if 'addin' is already installed
'in UserLibraryPath (error handling)
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
'install if no previous version exists
Call InstallAddIn
Else
'delete installed version & replace with this one if ok
If MsgBox(" The target folder already contains " & _
"a file with the same name... " & _
vbNewLine & vbNewLine & _
" (That file was last modified on: " & _
Workbooks(AddinName) _
.BuiltinDocumentProperties("Last Save Time") & ")" & _
vbNewLine & vbNewLine & vbNewLine & _
" Would you like to replace the existing file with " & _
"this one? " & _
vbNewLine & vbNewLine & _
" (This file was last modified on: " & _
.BuiltinDocumentProperties("Last Save Time") & ")", _
vbYesNo, "Add-in Is In Place - " & _
"Confirm File Replacemant...") = vbYes Then
Workbooks(AddinName).Close False
Kill Application.UserLibraryPath & AddinName
Call InstallAddIn
End If
End If
End With
End Sub
'---------------------------------------------------------------------
' Purpose : Convert .xla file to .xls format
' and move it to default file path
'---------------------------------------------------------------------
'
Private Sub RemoveAddIn()
Dim AddinTitle As String, AddinName As String
Dim XlaVersion As String
Application.ScreenUpdating = False
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
AddinName = AddinTitle & ".xla"
XlaVersion = .FullName
'check the 'addin' is not already removed
'from UserLibraryPath (error handling)
If Not Dir(Application.UserLibraryPath & AddinName) = Empty _
Then
.Sheets(1).Cells.ClearContents '< cleanup
Call RemoveButtons
'move & save as .xls file
.SaveAs Application.DefaultFilePath & _
"\" & AddinTitle & ".xls"
Kill XlaVersion '< delete .xla version
'uncheck checkbox in the addin dialog box
AddIns(AddinTitle).Installed = False
.IsAddin = False '< show workbook window
.Save
'inform user and close
MsgBox "The addin '" & AddinTitle & "' has been " & _
"removed and converted to an .xls file." & _
vbNewLine & vbNewLine & _
"Should you later wish to re-install this as " & _
"an addin, open the .xls file which" & _
vbNewLine & "can now be found in " & _
Application.DefaultFilePath & _
" as: '" & .Name & "'"
.Close
End If
End With
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------
' Purpose : Add addin control buttons
'---------------------------------------------------------------------
'
Private Sub AddButtons()
'change 'Startups...' to suit
Const MyControl As String = "Startups..."
'change 'Manage Startups' to suit
Const MyControlCaption As String = "Manage Startups"
Dim AddinTitle As String, Mybar As Object
AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
Call RemoveButtons
On Error GoTo ErrHandler
Set Mybar = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls _
.Add(Type:=msoControlPopup, before:=13)
'
With Mybar
.BeginGroup = True
.Caption = MyControl
'-------------------------------------------------------------
.Controls.Add.Caption = MyControlCaption
.Controls(MyControlCaption).OnAction = "ShowStartupForm"
'-------------------------------------------------------------
With .Controls.Add
.BeginGroup = True
.Caption = "Case " & AddinTitle
End With
.Controls("Case change " & AddinTitle).OnAction = "ULCase.UpperMacro"
'-------------------------------------------------------------
.Controls.Add.Caption = "Remove " & AddinTitle
.Controls("Remove " & AddinTitle).OnAction = "Module1.RemoveAddIn"
'-------------------------------------------------------------
End With
Exit Sub
ErrHandler:
Set Mybar = Nothing
Set Mybar = Application.CommandBars("Tools") _
.Controls.Add(Type:=msoControlPopup, before:=13)
Resume Next
End Sub
'
'---------------------------------------------------------------------
' Purpose : Remove addin control buttons
'---------------------------------------------------------------------
'
Private Sub RemoveButtons()
'
'change 'Startups...' to suit
Const MyControl As String = "Startups..."
On Error Resume Next
With Application
.CommandBars("Tools").Controls(MyControl).Delete
.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls(MyControl).Delete
End With
End Sub
I think the problem is with AddinTitle = Left(.Name, Len(.Name) - 4) as the hardcoded 4 will have to be adjusted between .xls & .xlsx extentions, or otherwise you could be left with a double period i.e. ..
Found the answer to my problem in the end so it did had to do with the save method failed.
So instead of the below line:
.SaveAs Application.UserLibraryPath & AddinName
Changed with this and it worked obviously I changed some parts of the code based on your suggestions.
.SaveAs Application.UserLibraryPath & AddinName, 55
While saving the file, the FileFormat option needs to be mentioned as well.
So instead of
.SaveAs Application.UserLibraryPath & AddinName
you can mention the file format as
.SaveAs Application.UserLibraryPath & AddinTitle FileFormat:=xlAddin
Another problem
You cannot Kill the file the current code is running from.
Basically, all the Kill ... statements in the code would produce permission error, because the running code would have put a lock on the file and the vba Kill is not a synchronous function.
I have the following question. I use a file to log assets (laptops, desktops etc) into certain folders, like deployed, stock, repair and hotswap.
I made some buttons in it which work all fine. One button called deployed, when I save the sheet with this button it saves it with EU IMAC, serial number and date as XLMS file.
I like to change the code from this button, so that when I save a sheet as deployed it automatically delete the XLMS file with serial number and name in the folder stock.
Below the codes for all the save buttons and it's button 61 that needs to be fixed, the others I will change afterwards. The code is form other forum, but with no success.
Sub Button60_Click()
Range("A1:G68").PrintOut
End Sub
Sub Button51_Click()
ActiveWorkbook.SaveAs "C:\Users\rjbakkex\Documents\Assets_logging\Hotswap\" & Format(ActiveWorkbook.Worksheets("EU IMAC").Range("B26").Value) & " - Hotswap -" & Format(Date, "yyyy-mm-dd") & ".xlsm"
End Sub
Sub Button53_Click()
ActiveWorkbook.SaveAs "C:\Users\rjbakkex\Documents\Assets_logging\Returned to stock\" & Format(ActiveWorkbook.Worksheets("EU IMAC").Range("B26").Value) & " - Return to stock - " & Format(Date, "yyyy-mm-dd") & ".xlsm"
End Sub
Sub awaitwuhan_Click()
ActiveWorkbook.SaveAs "C:\Users\rjbakkex\Documents\Assets_logging\To repair\" & Format(ActiveWorkbook.Worksheets("EU IMAC").Range("B26").Value) & "- Repair -" & Format(Date, "yyyy-mm-dd") & ".xlsm"
End Sub
Sub Button61_Click()
p = "C:\Users\rjbakkex\Documents\Assets_logging\Deployed\"
'opslaan
s_name = Sheets("EU IMAC").Range("B25").Value & " - Deployed -" & Format(Date, "yyyy-mm-dd") & ".xlsm"
ActiveWorkbook.SaveAs p & s_name
'verwijderen
d_name = Sheets("EU IMAC").Range("B25").Value & " - Return to stock -" & Format(Date, "yyyy-mm-dd") & ".xlsm"
If MsgBox("Are you sure that you want to remove " & d_name & " from the system?", vbQuestion + vbYesNo, "Sure?") = vbYes Then Kill p & d_name
End Sub
First, give your buttons meaningful names, that is such a garbled mess to try and determine what button60 is or does.
Second You need to use the file system object from Microsoft Scripting Library (add a reference in excel to this dll scrrun.dll) then you can check to see if the file exists and delete it
Sub Button61_Click()
p = "C:\Users\rjbakkex\Documents\Assets_logging\Deployed\"
'opslaan
s_name = Sheets("EU IMAC").Range("B25").Value & " - Deployed -" & Format(Date, "yyyy-mm-dd") & ".xlsm"
ActiveWorkbook.SaveAs p & s_name
'verwijderen
d_name = Sheets("EU IMAC").Range("B25").Value & " - Return to stock -" & Format(Date, "yyyy-mm-dd") & ".xlsm"
'create the file system object
Dim fso As FileSystemObject
Set fso = New FileSystemObject
'make sure the file exists first
If fso.FileExists(p & d_name) = True Then
If MsgBox("Are you sure that you want to remove " & d_name & " from the system?", vbQuestion + vbYesNo, "Sure?") = vbYes Then
fso.DeleteFile p & d_name, True
End If
End If
'free the memory
Set fso = Nothing
End Sub
I'm looking to create a macro that'll install an add-in for the user to the excel ribbon. I'm upto:
Private Sub Workbook_Open()
On Error Resume Next
Application.AddIns("Name of Addin").Installed = False
On Error GoTo 0
With Application
.AddIns.Add "Filepath to addin in shared location", False
.AddIns("Name of Addin").Installed = True
End With
ThisWorkbook.Close False
End Sub
Once running the macro, the addin installs to the ribbon no problems. The issue is, once excel is closed down, the addin no longer shows in the ribbon.
It would appear that excel is expecting the addin to be copied into the users C:\Documents and Settings\Username\Application Data\Microsoft\AddiIns folder as it throws the error that it can't find it when starting excel after closing down.
Now my understanding is that the second (false) variable for the line of code below basically says that the addin shouldn't be copied to the AddIns directory and rather should stay in the shared location.
.AddIns.Add "Filepath to addin in shared location", False
Any ideas on why Excel is expecting the addin to be in the users default folder?
I'll give it a try. Please see comments in code.
ThisWorkbook
Option Explicit
'
'---------------------------------------------------------------------
' Purpose : Call for installation as an addin if not installed
'---------------------------------------------------------------------
'
Private Sub Workbook_Open()
Dim AddinTitle As String, AddinName As String
Dim XlsName As String
AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
XlsName = AddinTitle & ".xlsm"
AddinName = AddinTitle & ".xla"
'check the addin's not already installed in UserLibraryPath
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
'ask if user wants to install now
If MsgBox("Install " & AddinTitle & _
" as an add-in?", vbYesNo, _
"Install?") = vbYes _
Then
Run "InstallAddIn"
End If
Else
If ThisWorkbook.Name = XlsName Then
Run "ReInstall"
End If
End If
End Sub
'
'---------------------------------------------------------------------
' Purpose : Actuate the addin, add custom controls
'---------------------------------------------------------------------
'
Private Sub Workbook_AddinInstall()
Run "AddButtons"
End Sub
'
'---------------------------------------------------------------------
' Purpose : Deactivate the addin, remove custom controls
'---------------------------------------------------------------------
'
Private Sub Workbook_AddinUninstall()
Run "RemoveButtons"
End Sub
Module
Option Explicit
'
'---------------------------------------------------------------------
' Purpose : Convert .xls file to .xla, move it to
' addins folder, and install as addin
'---------------------------------------------------------------------
'
Private Sub InstallAddIn()
Dim AddinTitle As String, AddinName As String
Dim XlsVersion As String, MessageBody As String
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
AddinName = AddinTitle & ".xlam"
XlsVersion = .FullName '< could be anywhere
'check the addin's not installed in
'UserLibraryPath (error handling)
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
.IsAddin = True '< hide workbook window
'move & save as .xla file
.SaveAs Application.UserLibraryPath & AddinName, 55
'go thru the add-ins collection to see if it's listed
If Listed Then
'check this addins checkbox in the addin dialog box
AddIns(AddinTitle).Installed = True '<--Error happening if .xlam format
Else
'it's not listed (not previously installed)
'add it to the addins collection
'and check this addins checkbox
AddIns.Add(ThisWorkbook.FullName, True) _
.Installed = True
End If
'inform user...
MessageBody = AddinTitle & " has been installed - " & _
"to access the tools available in" & _
vbNewLine & _
"this addin, you will find a button in the 'Tools' " & _
"menu for your use"
If BooksAreOpen Then '< quit if no other books are open
.Save
MsgBox MessageBody & "...", , AddinTitle & _
" Installation Status..."
Else
If MsgBox(MessageBody & " the" & vbNewLine & _
"next time you open Excel." & _
"" & vbNewLine & vbNewLine & _
"Quit Excel?...", vbYesNo, _
AddinTitle & " Installation Status...") = vbYes Then
Application.Quit
Else
.Save
End If
End If
End If
End With
End Sub
'---------------------------------------------------------------------
' Purpose : Checks if this addin is in the addin collection
'---------------------------------------------------------------------
'
Private Function Listed() As Boolean
Dim Addin As Addin, AddinTitle As String
Listed = False
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
For Each Addin In AddIns
If Addin.Title = AddinTitle Then
Listed = True
Exit For
End If
Next
End With
End Function
'---------------------------------------------------------------------
' Purpose : Check if any workbooks are open
' (this workbook & startups excepted)
'---------------------------------------------------------------------
'
Private Function BooksAreOpen() As Boolean
'
Dim Wb As Workbook, OpenBooks As String
'get a list of open books
For Each Wb In Workbooks
With Wb
If Not (.Name = ThisWorkbook.Name _
Or .Path = Application.StartupPath) Then
OpenBooks = OpenBooks & .Name
End If
End With
Next
If OpenBooks = Empty Then
BooksAreOpen = False
Else
BooksAreOpen = True
End If
End Function
'---------------------------------------------------------------------
' Purpose : Replace addin with another version if installed
'---------------------------------------------------------------------
'
Private Sub ReInstall()
Dim AddinName As String
With ThisWorkbook
AddinName = Left(.Name, Len(.Name) - 4) & ".xla"
'check if 'addin' is already installed
'in UserLibraryPath (error handling)
If Dir(Application.UserLibraryPath & AddinName) = Empty Then
'install if no previous version exists
Call InstallAddIn
Else
'delete installed version & replace with this one if ok
If MsgBox(" The target folder already contains " & _
"a file with the same name... " & _
vbNewLine & vbNewLine & _
" (That file was last modified on: " & _
Workbooks(AddinName) _
.BuiltinDocumentProperties("Last Save Time") & ")" & _
vbNewLine & vbNewLine & vbNewLine & _
" Would you like to replace the existing file with " & _
"this one? " & _
vbNewLine & vbNewLine & _
" (This file was last modified on: " & _
.BuiltinDocumentProperties("Last Save Time") & ")", _
vbYesNo, "Add-in Is In Place - " & _
"Confirm File Replacemant...") = vbYes Then
Workbooks(AddinName).Close False
Kill Application.UserLibraryPath & AddinName
Call InstallAddIn
End If
End If
End With
End Sub
'---------------------------------------------------------------------
' Purpose : Convert .xla file to .xls format
' and move it to default file path
'---------------------------------------------------------------------
'
Private Sub RemoveAddIn()
Dim AddinTitle As String, AddinName As String
Dim XlaVersion As String
Application.ScreenUpdating = False
With ThisWorkbook
AddinTitle = Left(.Name, Len(.Name) - 4)
AddinName = AddinTitle & ".xla"
XlaVersion = .FullName
'check the 'addin' is not already removed
'from UserLibraryPath (error handling)
If Not Dir(Application.UserLibraryPath & AddinName) = Empty _
Then
.Sheets(1).Cells.ClearContents '< cleanup
Call RemoveButtons
'move & save as .xls file
.SaveAs Application.DefaultFilePath & _
"\" & AddinTitle & ".xls"
Kill XlaVersion '< delete .xla version
'uncheck checkbox in the addin dialog box
AddIns(AddinTitle).Installed = False
.IsAddin = False '< show workbook window
.Save
'inform user and close
MsgBox "The addin '" & AddinTitle & "' has been " & _
"removed and converted to an .xls file." & _
vbNewLine & vbNewLine & _
"Should you later wish to re-install this as " & _
"an addin, open the .xls file which" & _
vbNewLine & "can now be found in " & _
Application.DefaultFilePath & _
" as: '" & .Name & "'"
.Close
End If
End With
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------
' Purpose : Add addin control buttons
'---------------------------------------------------------------------
'
Private Sub AddButtons()
'change 'Startups...' to suit
Const MyControl As String = "Startups..."
'change 'Manage Startups' to suit
Const MyControlCaption As String = "Manage Startups"
Dim AddinTitle As String, Mybar As Object
AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
Call RemoveButtons
On Error GoTo ErrHandler
Set Mybar = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls _
.Add(Type:=msoControlPopup, before:=13)
'
With Mybar
.BeginGroup = True
.Caption = MyControl
'-------------------------------------------------------------
.Controls.Add.Caption = MyControlCaption
.Controls(MyControlCaption).OnAction = "ShowStartupForm"
'-------------------------------------------------------------
With .Controls.Add
.BeginGroup = True
.Caption = "Case " & AddinTitle
End With
.Controls("Case change " & AddinTitle).OnAction = "ULCase.UpperMacro"
'-------------------------------------------------------------
.Controls.Add.Caption = "Remove " & AddinTitle
.Controls("Remove " & AddinTitle).OnAction = "Module1.RemoveAddIn"
'-------------------------------------------------------------
End With
Exit Sub
ErrHandler:
Set Mybar = Nothing
Set Mybar = Application.CommandBars("Tools") _
.Controls.Add(Type:=msoControlPopup, before:=13)
Resume Next
End Sub
'
'---------------------------------------------------------------------
' Purpose : Remove addin control buttons
'---------------------------------------------------------------------
'
Private Sub RemoveButtons()
'
'change 'Startups...' to suit
Const MyControl As String = "Startups..."
On Error Resume Next
With Application
.CommandBars("Tools").Controls(MyControl).Delete
.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls(MyControl).Delete
End With
End Sub
Code is below which was working fine, now does not seem to like the ".xlsm" section. problem is on all PCs. I tried using the Filename= and a few variants and have pinned it down to "." (period) that it does not accept in ".xlsm", delete the period and it is fine but then lands in SharePoint as an unknown file (with no file extension). Any advice appreciated!
Sub SUBMIT()
Dim FName As String
FName = Range("E3").Text
FDate = Range("I3").Text
If Range("E3") = "" Then
MsgBox "Please Enter Your Name"
Range("E3").Select
ElseIf Range("I3") = "" Then
MsgBox "Please Enter Fortnight Ending Date"
Range("I3").Select
ElseIf Range("I3") <> "" Then
If MsgBox("Are you sure? (Have you entered your supervisor(s) and Fortnight End Date in the top panel ?", vbYesNo) = vbNo Then Exit Sub
ActiveWorkbook.SaveAs ("https://*****.sharepoint.com/corp/payroll/Timesheets" & FName & " " & FDate & " " & "Timesheet" & "xls")
MsgBox "Timesheet Submitted"
End If
End Sub
You should supply the file path without the extension and use the FileFormat parameter of the ActiveWorkbook.SaveAs() function.
In your case, you should change the row to this
ActiveWorkbook.SaveAs ("https://*****.sharepoint.com/corp/payroll/Timesheets" & FName & " " & FDate & " " & "Timesheet"), 52
The 52 I added at the end is the value for xlOpenXMLWorkbookMacroEnabled as described here
The code below works well for me on Win7 Excel2013
Sub StackOverflow()
ActiveWorkbook.SaveAs "C:\Temp\myfile", 52
End Sub