VBA .VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString isn't working - excel

I am creating a bunch of workbooks dynamically that are linked and I need to suppress the linked warning, so I am trying to add a Workbook_Open() sub with the proper code.
Only problem is that the code isn't actually being added to the workbook.
' do not display alerts while processing so many files
Application.DisplayAlerts = False
wbNew.SaveAs FileName:=path, FileFormat:=51, CreateBackup:=False
' add a little Workbook_Open method to the new workbook's ThisWorkbook dynamically
' this line doesn't actually do anything - why?
wbNew.VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString ( _
"Private Sub Workbook_Open()" & vbCrLf _
& " Application.AskToUpdateLinks = False" & vbCrLf _
& " Application.DisplayAlerts = False" & vbCrLf _
& "End Sub")
wbNew.Save
wbNew.Close
The file is created and all is well, except that no code is actually added to the workbook I just made, it's a normal workbook and its ThisWorkbook is blank. (I also checked that I wasn't suppressing any warnings about the dynamic code writing, just the normal saveas prompts).
How can I make this work?

This works for me, no prompts or missing codes:
Sub test()
Dim wbnew As Workbook
Set wbnew = Workbooks.Add
Application.DisplayAlerts = False
wbnew.SaveAs Filename:="C:\temp\abc.xlsm", FileFormat:=XlFileFormat.xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wbnew.VBProject.VBComponents.Item("ThisWorkbook").CodeModule.AddFromString ( _
"Private Sub Workbook_Open()" & vbCrLf _
& " Application.AskToUpdateLinks = False" & vbCrLf _
& " Application.DisplayAlerts = False" & vbCrLf _
& "End Sub")
wbnew.Close True
Application.DisplayAlerts = True
End Sub
For macro prompt settting Fil--> Options--> Trust Center --> Macro Setting to this will get rid of the prompt:

Related

Subscript Out of Range Error When Closing Workbook

I'm currently trying to edit a macro that opens a base file [myFile], runs a separate macro in that base file. By running this base file, an entirely new workbook is created [myFile2]. The goal is to take myFile2, do some resizing, move some sheets around, etc., and create a differently formatted report [myFile3].
Everything is working fine until I go to close the workbooks, where I'm getting a subscript out of range error.
This wasn't my original code. I'm now editing it, and I don't have access to the original author. The word 'FALSE' is by each of the workbook close statements, and I'm also wondering if that is related to save changes or something else that could be contributing to the problem?
myPath = "\this\is\a\file\path"
myFile = "base.xlsm"
myPath2 = "\this\is\another\path"
myFile2 = Format(Date, "yymmdd") & "-base_results" & ".xlsm"
myPath3 = "\this\is\a\third\path"
myFile3 = "formatted_base_results" & Format(Date, "mm-dd-yyyy") & ".xlsm"
'open workbook to run macros
Set wkb = Workbooks.Open(Filename:=myPath2 & "\" & myFile2, UpdateLinks:=False)
'run macros in opened workbook
Application.Run ("'" & wkb.Name & "'!" & "MoveSheets")
DoEvents
Application.Run ("'" & wkb.Name & "'!" & "FormatSheets")
DoEvents
Application.Run ("'" & wkb.Name & "'!" & "NewDocument")
DoEvents
'close workbooks
'cant index by full file name
Workbooks(myFile).Close False
Workbooks("DailyBuildPrint - Avg Fare" & Format(Date, "mm-dd-yyyy") & ".xlsm").Close False
Workbooks(myFile2).Close False

Auto-install Excel vba addins

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.

Run-time error '1004': SaveAs Method of object '_Workbook failed

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

Runtime error 1004 document not saved with Vba Excel 2016

I am getting a Runtime error 1004 document not saved using vba when I want to save an Excel workbook in my folder on desktop. Here are the details of my code:
Private Sub Save_Click()
'Popup the Window "Save As"
Application.DisplayAlerts = False
MsgBox "Do not change the default file name proposed on the next step please !"
Dim fName As Variant
Dim DName As String ' Variable storing name of excel workbook which has to be saved
DName = UserForm.CustomerApplication.Value & " - " & UserForm.L2GType.Value
& " - " & UserForm.Title.Value & " - " & UserForm.Country.Value & "(" &
Year(Date) & ")"
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName = False Then
Exit Sub
ActiveWorkbook.SaveAs filename:=fName, FileFormat:=51
ActiveWorkbook.Close
End Sub
I think you are missing an 'End If' at the bottom of your code. The 'If fName = False Then...' part. Try the following
Private Sub Save_Click()
'Popup the Window "Save As"
Application.DisplayAlerts = False
MsgBox "Do not change the default file name proposed on the next step please !"
Dim fName As Variant
Dim DName As String ' Variable storing name of excel workbook which has to be saved
DName = UserForm.CustomerApplication.Value & " - " & UserForm.L2GType.Value
& " - " & UserForm.Title.Value & " - " & UserForm.Country.Value & "(" &
Year(Date) & ")"
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName = False Then
Exit Sub
End If
ActiveWorkbook.SaveAs filename:=fName, FileFormat:=51
ActiveWorkbook.Close
End Sub
fName is a String, therefore you can't compare it with False, but with "False".
Try replacing the last section of your code with the lines below:
fName = Application.GetSaveAsFilename(InitialFileName:=DName, _
fileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Save As")
If fName <> "False" Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=51
Else
MsgBox "No File was selected !"
Exit Sub
End If
Application.DisplayAlerts = True
Note: using FileFormat:=51, means xlOpenXMLWorkbook, an .xlsx format (without MACROs).
However since you want to use the SaveAs command with ThisWorkbook, which contains this code, you will get a prompt screen that asks if you want to save it as .xslx , which means all your code will be lost.
You can select FileFormat:=52, means xlOpenXMLWorkbookMacroEnabled, an .xlsm format (with MACROs).

VBA code creating false.xml files

I use the code below to save a workbook using two fields as the name. This part works dead on but when the save as window opens and i click cancel, it creates a false.xml excel file. Not sure as to why. I have tried using without the if statement but still creates it.
Can someone tell me why this happens and how to stop it?
Also is there code to catch errors in vb?
Regards
Sub FileSave()
Dim IntialName As String
Dim fileSaveName As Variant
InitialName = Range("C2") & " " & Range("H2") & " Cash Sheet"
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitialName, _
fileFilter:="Excel Files (*.xls), *.xls")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
ActiveWorkbook.SaveAs fileSaveName
End Sub
In your code you check for If fileSaveName <> False but if it is false you save the workbook in spite. So VBA builds an filename from this False value. Write
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
ActiveWorkbook.SaveAs fileSaveName
End If
instead.
For error handling in VBA look here.

Resources