I'm using the following code to save an updated workbook.
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
gwbTarget.Activate <<<<<<<<<<<<<<<<<<<<<<<
Application.DisplayAlerts = False
gwbTarget.SaveAs txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = False
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Exit Sub
Err_cmdSaveUpdatedWB_Click:
MsgBox "The following error occurred inthe [cmdSaveUpdateWB_Click] event handler." & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & "Error descriptioin: " & Err.Description
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
As noted in the title, the SaveAs operation fails. I've determined that the failure is a result of having the workbook to be saved losing the focus. I can step through the code and get the error. Once the error is generated, selecting Debug in the error message box and then pressing F5 to run the code will result in the workbook saving correctly. Placing Debug.Print statements before and after the Activate method of the worbook to be saved indicates that the active wokbook is the workbook containing the code and the form used to update the workbook. Placing a print statement in the Immediate wondow that prints the ActiveWorkbook.Name will result in printing the name of the workbook to be saved - gwbTarget.Name. Pressing F5 then runs the code correctly.
I have been unable to figure out why the workbook to be saved loses the focus. I placed delays, multiple activation statements, local variables to use for the workbookto be saved, and for the name of the workbook to be saved. Any help or ideas as to why this is happening and how to fix it will be greatly appreciated.
I did make some changes. The code is listed below...
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
Dim wbSave As Workbook
Set wbSave = gwbTarget
gwbTarget.Activate
Application.DisplayAlerts = False
''''''' gwbTarget.SaveAs txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wbSave.SaveAs fileName:=txtUpdWorkbookName.Value, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = False
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Set wbSave = Nothing
Exit Sub
Err_cmdSaveUpdatedWB_Click:
MsgBox "The following error occurred inthe [cmdSaveUpdateWB_Click] event handler." & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & "Error descriptioin: " & Err.Description
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
I've changed the code to more closely resemble the suggestion below. The listing is below, along with the variable definitions as they were upon entry into the program. The Excel code is running in a Citrix environment which may effect timing but shouldn't have any other effect on code execution.
I deleted the other code versions for brevity. The following code is what has worked. The key issue is that the workbook to be saved must be the active workbook when the SaveAs method is invoked.
Private Sub cmdSaveUpdatedWB_Click()
On Error GoTo Err_cmdSaveUpdatedWB_Click
Dim wbSave As Workbook
Dim wsActive As Worksheet
Dim sNWBName As String
Application.DisplayAlerts = False
sNWBName = txtUpdWorkbookName.Value
Set wbSave = gwbTarget
wbSave.Activate
Set wsActive = wbSave.ActiveSheet
wbSave.SaveAs fileName:=sNWBName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
frmLoanWBMain.Show
gwbTarget.Close
Set gwbTarget = Nothing
gWBPath = ""
gWBName = ""
lblWorkbookSaved.Enabled = True
cmdUpdateAnotherWorkbook.Visible = True
Exit_cmdSaveUpdatedWB_Click:
Set wbSave = Nothing
Exit Sub
Err_cmdSaveUpdatedWB_Click:
Dim strErrMsg As String
strErrMsg = "Error Number: " & Err.Number & " Desc: " & Err.Description & vbCrLf & _
"Source:" & Err.Source & vbCrLf & _
"Updating Workbook: " & vbCrLf & " " & gwbTarget.Name & vbCrLf & _
"Selected Worksheet: " & gwsTrgSheet.Name & vbCrLf & _
"Active Workbook: " & vbCrLf & " " & ActiveWorkbook.Name & vbCrLf & _
"Worksheet: " & ActiveSheet.Name & vbCrLf & _
"Code Segment: cmdSaveUpdatedWB_Click event handler"
RecordErrorInfo strErrMsg
Resume Exit_cmdSaveUpdatedWB_Click
End Sub
Why don't you start with something like this
Private Sub cmdSaveUpdatedWB_Click()
Dim gwbTarget As Workbook
Set gwbTarget = Workbooks("workbook_name.xlsm") 'correct extension needed, workbook must be open
wb.SaveAs Filename:=gwbTarget.Path, FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "Last saved: " & gwbTarget.BuiltinDocumentProperties("Last Save Time")
End Sub
Change one thing at a time to make it more like yours and hopefully it'll all work fine!
Update
As per the comments. If you are trying to open, update and close hundreds of workbooks. You can use this as a guide:
Sub ChangeWorkbooks()
Application.ScreenUpdating = False
Dim wbPaths As Range, wbSaveFilenames As Range
With Sheet1 'you will need to update this and the ranges below
Set wbPaths = .Range("A1:A650") 'including file extensions
Set wbSaveFilenames = .Range("B1:B650") 'including file extensions
End With
Dim i As Integer, totalBooks As Integer
Dim wbTemp As Workbook
totalBooks = wbPaths.Rows.Count
For i = 1 To totalBooks
Application.StatusBar = "Updating workbook " & i & " of " & totalBooks 'display statusbar message to user
Set wbTemp = Workbooks.Open(wbPaths.Cells(i, 1), False)
'make changes to wbTemp here
wbTemp.SaveAs wbSaveFilenames.Cells(i, 1)
wbTemp.Close
Next i
Set wbTemp = Nothing
Application.ScreenUpdating = True
Applicaton.StatusBar = False
End Sub
Related
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 this code:
Sub PrintPDF()
Dim wsReport As Worksheet
Dim confirm As Long
Dim filename, reportsPath As String
Dim printArea As Range
Set wsReport = ThisWorkbook.Worksheets("Test Status")
Set printArea = wsReport.Range("A1:AG80")
'Generate Reports folder path
'reportsPath = ThisWorkbook.Path & "\Reports\"
reportsPath = "C:\"
'Generate filename to be printed
Dim LValue As String
LValue = Format(Date, "yyyymmdd")
fp = reportsPath & Range("Project!clientName").Value & "_TestReport_" & LValue & ".pdf"
'Confirm or Cancel the action
confirm = MsgBox("the Test execution report (" & fp & ") will be printed as PDF in the folder " & reportsPath & " .", vbOKCancel + vbQuestion, "Printing Test report")
If confirm = vbCancel Then
Exit Sub
End If
'Set page orientation to landscape
wsReport.PageSetup.Orientation = xlLandscape
'wsReport.PageSetup.Orientation = xlPortrait
Application.ScreenUpdating = False
With ActiveSheet.PageSetup
.printArea = Worksheets("Test Status").UsedRange
'.printArea = wsReport.UsedRange
'.printArea = Worksheets("Test Status").UsedRange
.Orientation = xlLandscape
.FitToPagesWide = 1
.Zoom = False 'I have added this line
End With
printArea.ExportAsFixedFormat Type:=xlTypePDF, filename:=fp, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
This code is activated when the button on the sheet is pressed.
Once I press the button, I got the message box with the filename and path where the file will be stored.
once pressed on "OK" button I got this error:
Run-Time Error '1004' Document not saved. The document may be open or
an error may have been encountered
I'm using Office 365
fixed,
seems that the issue was caused by directory grant.
Btw, I changed the reportsPath
reportsPath = ThisWorkbook.Path & "\Reports\"
And I've added the check to create the directory in case it doesn't exist.
reportsPath = ThisWorkbook.Path & "\Reports\"
If Dir(reportsPath, vbDirectory) = "" Then
create = MsgBox("The Directory " & reportsPath & " doesn't exist. ", vbOKCancel + vbQuestion, "Do you want to create it?")
If create = vbCancel Then
Exit Sub
End If
MkDir reportsPath
Stop
End If
Now it works, no runtime error anymore.
I run VBA code in Access and update an existing Excel file.
I have to create xls files for each sales person and update the cells by grouping customer of monthly sales point by exporting data from an Access accdb file which is connected to Oracle database by ODBC driver.
We have about 50 sales persons and will have to create 2 files on each. If I can not fix the problem I will have 100 Excel processes on my PC. It might be frozen when run even if I successfully run the accdb with VBA.
Problems:
Can not close Excel process by Application.Quit which I tried to
open a xls file by Excel.Application.Workbooks object and it seems
be it's caught the xls file still even I used .Close
SaveChanges:=True
Can not process the VBA code again against same file cause of the
previous excel file operation process is left which I confirmed it
on task manager that I have to kill the process manually every time.
I googled on the internet and MSDN site. I could not find any good solution.
Option Compare Database
Const TARGET_SHEET = "SalesObjectiveSheet"
Const FILE_CREATION_WORK_FOLDER As String = "Work"
Const DESTINATION_ROOTPATH As String = "C:\Users\Administrator\Desktop"
Const TARGET_SHEET2 As String = "SalesObjectivesSheet"
Const HEADING_LINE_POSITION As Integer = 3
Public objApp As Excel.Application
Public objBooks As Excel.Workbooks
Public objBook As Excel.Workbook
Public objSheets As Excel.Worksheets
Public objSheet As Excel.Worksheet
Public Sub test200()
Dim str As Boolean
On Error GoTo Err_Handler
strSalesName = "SalesName"
strSalesOffice = "Tokyo"
strTargetFolder = DESTINATION_ROOTPATH & "\" & FILE_CREATION_WORK_FOLDER
strTargetFileName = "SalesObjectiveSheet_201708.xlsx"
strTargetFullPath = strTargetFolder & "\" & strTargetFileName
Set objApp = CreateObject("Excel.Application")
Set objBook = objApp.Workbooks.Open(strTargetFullPath)
Set objSheet = objBook.Worksheets(TARGET_SHEET2)
If EditObjectSheetHeader(objSheet, objApp, objBook, _
objBooks, strSalesName, strSalesOffice, strTargetFileName) = False Then
GoTo Err_Handler
End If
Exit_Handler:
objApp.Quit
Set objSheet = Nothing
Set objBooks = Nothing
Set objApp = Nothing
Exit Sub
Err_Handler:
' SysCmd acSysCmdRemoveMeter
Resume Exit_Handler
End Sub
Function EditObjectSheetHeader(objSheet As Object, objApp As Object, objBook As Object, _
objBooks As Object, strSalesName, strSalesOffice, strTargetFileName) As Boolean
Dim strProcedureName As String
Dim strMonth As String
On Error GoTo Err_Handler
objSheet.Select
objSheet.Activate
strProcedureName = "EditObjectSheetHeader"
EditObjectSheetHeader = False
With objSheet.PageSetup
.CenterHeader = "&14 " & "Month Sales Objectives"
.RightHeader = "" & Chr(10) & "Sales Office:" & strSalesOffice & " Name:" & strSalesName
.CenterFooter = "&P/&N"
.PrintTitleRows = "$1:$" & HEADING_LINE_POSITION
.LeftHeader = ""
End With
Exit_Handler:
Workbooks(strTargetFileName).Close SaveChanges:=True
' Frozen after I run the VBA code once cause of previous & _
process use same file is existed it seems be.
' ActiveWorkbook.Close saveChanges:=True
' Frozen after I run the VBA code once cause of & _
previous process use same file is existed & _
(Object and With is not defined error)
' objBook.Close SaveChanges:=True
' Frozen after I run the VBA code once cause of & _
previous process use same file is existed & _
it seems be.
' ActiveWorkbook.Close SaveChanges:=True
' Error unknown.
' ThisWorkbook.Save
'Error 1004 unknown.
EditObjectSheetHeader = True
Exit Function
Err_Handler:
Select Case Err.Number
Case 9
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbOKOnly, strProcedureName
Case 70
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbOKOnly, strProcedureName
Resume
Case Else
Debug.Print strProcedureName, Err.Number, Err.Description
MsgBox Err.Description & " " & Err.Number, vbExclamation, strProcedureName
End Select
End Function
Below line helped, but any other opened xls also will be closed:
Shell "taskkill /F /IM EXCEL.EXE /T"
Try placing objApp.Quit after releasing references.
Set objSheet = Nothing
Set objBooks = Nothing
Set objApp = Nothing
If Not objApp is Nothing Then objApp.Quit
HELP! I cannot find this anywhere... I have found plenty of explanations of .frx files but that is not the issue. I have exported 2 modules ".bas" and a userform ".frm" that also created the ".frx" binary file. The issue is that now when I import them to a new workbook with the code below, upon initializing the userform, the application opens and tries to run in the original workbook, in which I wrote the modules and designed the custom userform. Why is this happening and is there a way to get it to load the userform in the workbook that the form and modules were imported into?
Sub Import_VBA(WBName)
Dim VBc As Variant
Dim exportFolder As String, VBcExt As String, testFile As String
Dim newWB As Workbook
testFile = WBName
exportFolder = "y:\ECI\Database\Outputs\InterfaceApp"
Set newWB = Workbooks(testFile & ".xlsm")
''''' Test VBA protection
On Error Resume Next
If newWB.VBProject.Protection <> 0 Then
If Err.Number = 1004 Then
Err.Clear
MsgBox "VBA Project Object Model is protected in " & newWB.Name & vbCrLf _
& vbCrLf & "Please remove VBA protection in Trust Center to continue.", _
vbExclamation + vbOKOnly, "Error"
Set newWB = Nothing
Exit Sub
Else
MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error"
Set newWB = Nothing
Err.Clear
Exit Sub
End If
End If
''''' Add Interface App Components
For Each VBc In CreateObject("Scripting.FileSystemObject").GetFolder(exportFolder).Files
Select Case LCase(Right(VBc.Name, 4))
Case ".bas", ".frm", ".cls", ".frx"
newWB.VBProject.VBComponents.Import exportFolder & "\" & VBc.Name
End Select
Next VBc
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