VBA kill crashes after being called by auto_open - vba

I'm experiencing some trouble with my VBA code. I have created an application in Excel and its copies have been distributed to users. To be able to correct bugs or add some new functions, every copy stores information what version it is. I have written procedure, that opens (read-only) a central file, that is providing some data a and information, which version is current. If the file, that opened this central file is older, it gets updated.
So the auto_open calls a procedure discovers that it has to be updated, saves the current file AS FileName_old.xlsm (to have some backup), kills the FileName.xlsm and copies a new file from a template. The problem is that the procedure crashes when it tries to kill the old file (to be more precise, it just ends without any error message). What confuses me is that when I run the auto_open macro manually (F5), everything goes correctly. Even step by step goes right. Also, when I call the update process via a button in a worksheet, it works perfectly. Any idea, what might cause this problem?
Thanks
Sub auto_open()
If Range("H_User").Value = "" Then UserNameWindows 'Write a user that is using this workbook in the range H_User
If Range("H_Updated").Value < FileDateTime(Range("H_File_Data").Value) Then UpdateData
End Sub
Sub UpdateData()
Dim ActWB As String
ActWB = ActiveWorkbook.Name
Application.ScreenUpdating = False
ThisWorkbook.Activate
If Not FileExists(Range("H_File_Data").Value) Then
MsgBox "The data file is not available!", vbCritical
Workbooks(ActWB).Activate
Application.ScreenUpdating = True
Exit Sub
End If
Dim WB As String, oknoData As String, IsTeam As Boolean, User As String
Dim version As Integer, Subversion As Integer, DataPath As String
On Error GoTo konec
Application.EnableCancelKey = xlDisabled
IsTeam = False
User = Range("H_User").Value
WB = ActiveWindow.Caption
version = Range("H_version").Value
Subversion = Range("H_Subversion").Value
Range("C_Data_All").ClearContents
DataPath = Range("H_File_Data").Value
Workbooks.Open fileName:=DataPath, ReadOnly:=True
oknoData = ActiveWindow.Caption
If Range("H_version_Spec").Value <= version Or (Range("H_version_Spec").Value = version And Range("H_Subversion_Spec").Value <= Subversion) Then
FileUpdate
End If
'If there is no need to update the file then continue with in this procedure
End Sub
Sub FileUpdate()
Dim NewPath As String, NewWB As String, OldPath As String, OldWB As String, BackupWB As String, BackupPath As String
Dim MainWB As String, version As String, Subversion As String
Dim versionMax As Integer, SubversionMax As Integer, versionMin As Integer, SubversionMin As Integer
ThisWorkbook.Activate
version = Range("H_version").Value
Subversion = Range("H_Subversion").Value
OldPath = ThisWorkbook.FullName
OldWB = ThisWorkbook.Name
BackupWB = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "_old.xlsm"
BackupPath = ThisWorkbook.Path & "\" & BackupWB
If Not FileExists(Workbooks(OldWB).Names("H_File_Data").RefersToRange.Value) Then
MsgBox "The data file is not available!", vbCritical
Exit Sub
End If
Workbooks.Open fileName:=Workbooks(OldWB).Names("H_File_Data").RefersToRange.Value, ReadOnly:=True
MainWB = ActiveWorkbook.Name
If version = Range("O_Spec_version").Value And Subversion >= Range("O_Spec_Subversion").Value Then
'Just some little piece of code if the version is not lower
Else
If FileExists(BackupPath) Then Kill (BackupPath)
If Not FileExists(Range("H_Path_Spec_Actual").Value) Then
MsgBox "The spec template is not available!", vbCritical
Exit Sub
End If
ThisWorkbook.SaveAs BackupPath
Kill (OldPath)
'Continue with update
End If
End Sub
Function FileExists(FilePath As String) As Boolean
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
FileExists= fso.FileExists(FilePath)
End Function

Option Explicit
Private Sub Workbook_Open()
Dim BackupPath As String
Dim OldPath As String
BackupPath = "folder\Filename_old.xlsm"
With ThisWorkbook
OldPath = .FullName
.SaveCopyAs BackupPath
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
End Sub

Related

Saving new Excel document as macro-free workbook without prompt

I'm using Excel 2010. I have an Excel macro-enabled template that has a data connection to a text file that is set to automatically refresh when a new document is created using this template.
The following macro is within the "ThisWorkbook" object to remove the data connection before saving the new document:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Do While ActiveWorkbook.Connections.Count > 0
ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
Loop
End Sub
When a user clicks the save icon / hits ctrl+S, inputs a filename and then clicks save to save as a macro-free Excel workbook (as is the default and required filetype) they are prompted with a message stating:
The following features cannot be saved in macro-free workbooks:
• VB project
To save a file with these features, click No, and then choose a
macro-enabled file type in the File Type list.
To continue saving as a macro-free workbook, click Yes.
Is it possible to prevent this message from appearing and have Excel assume that the user wants to continue with a macro-free workbook?
I've searched all over and understand that I may be able to add code to the workbook object that removes itself so that Excel has no VB project to cause this message but this would require each user to change Trust Center Settings (Trust access to the VBA project object model) which I want to avoid.
I've also seen suggestions of using:
Application.DisplayAlerts = False
but can't get this to work. Every example of it's use seems to be within a sub that is also handling the saving of the document whereas in my situation the BeforeSave sub ends before the document is saved in the default, non-vba way which is perhaps why it does not work?
Does this property reset to a default True after the sub has ended / before the save actually occurs?
Apologies for any nonsense I may have dispensed, my experience with VBA is very limited.
I cannot test on Excel 2010, but at least for 2016, it's working fine:
Sub SaveAsRegularWorkbook()
Dim wb As Workbook
Dim Path As String
Set wb = ThisWorkbook
Path = "T:\he\Path\you\prefer\"
Application.DisplayAlerts = False
Application.EnableEvents = False
wb.SaveAs Filename:=Path & "Test.xlsx", FileFormat:=51
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Give it a try.
Different approach... when the template is loaded, require the user to save as (I have a workbook/template with a similar situation...). This should open them up to the user's Documents folder, though you can adjust to save to whatever location.
Inside of the ThisWorkbook module, put:
Option Explicit
Private Sub Workbook_Open()
Dim loc As Variant
Application.DisplayAlerts = False
loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:="%USERPROFILE%\Documents\NAME_OF_FILE")
If loc <> False Then
ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=51
Exit Sub
End If
Application.DisplayAlerts = True
End Sub
Edit1: Adding the if statement using a base-template name, so subsequent saves do not prompt the save-as:
Option Explicit
Private Sub Workbook_Open()
If ActiveWorkbook.Name = "_NAME_OF_FILE.xlsb" Then
Dim loc As Variant
Application.DisplayAlerts = False
loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:="%USERPROFILE%\Documents\_NAME_OF_FILE")
If loc <> False Then
ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=51
Exit Sub
End If
Application.DisplayAlerts = True
End If
End Sub
For this answer, I'm assuming that by Excel macro-enabled template, you mean a xltm file. I also guess that what you mean by "new document" is the document that is generated when a user double-clicks on the xtlm file (hence this new file has no location on since it hasn't been saved yet).
To solve your issue, you could use a custom SaveAs window (Application.GetSaveAsFilename) to have more control on how the user saves the file when the Workbook_BeforeSave event macro gets called.
Here is how to implement it:
1 - Copy this code into a new module.
Option Explicit
Sub SaveAsCustomWindow()
Const C_PROC_NAME As String = "SaveAsCustomWindow"
Dim strFullFileName As String, strPreferedFolder As String, strDefaultName As String
Dim UserInput1 As Variant, UserInput2 As Variant
Dim isValidName As Boolean, isFileClosed As Boolean, isWorkbookClosed As Boolean
Dim strFilename As String, strFilePath As String
'To avoid Warning when overwriting
Application.DisplayAlerts = False
'Disable events (mostly for the BeforeSave event) to avoid creating infinite loop
Application.EnableEvents = False
On Error GoTo ErrHandler
'Customizable section
strDefaultName = ThisWorkbook.Name
strPreferedFolder = Environ("USERPROFILE")
Do While isWorkbookClosed = False
Do While isFileClosed = False
Do While isValidName = False
UserInput1 = Application.GetSaveAsFilename(InitialFileName:=strPreferedFolder & "\" & strDefaultName, FileFilter:="Excel Workbook (*.xlsx),*.xlsx")
If UserInput1 = False Then
GoTo ClosingStatements 'This is important to take care of the case when the user presses cancel
Else
strFullFileName = UserInput1
End If
strFilename = Right(strFullFileName, Len(strFullFileName) - InStrRev(strFullFileName, "\"))
strDefaultName = strFilename
strFilePath = Left(strFullFileName, InStrRev(strFullFileName, "\") - 1)
strPreferedFolder = strFilePath
'If the file exist, ask for overwrite permission
If Dir(strFullFileName) <> "" Then
UserInput2 = MsgBox(strFilename & " already exists." & vbNewLine & "Do you want to overwrite?", vbYesNoCancel Or vbExclamation)
If UserInput2 = vbNo Then
isValidName = False
ElseIf UserInput2 = vbYes Then
isValidName = True
ElseIf UserInput2 = vbCancel Then
GoTo ClosingStatements
Else
GoTo ClosingStatements
End If
Else
isValidName = True
End If
Loop
'Check if file is actually open
If isFileOpen(strFullFileName) Then
MsgBox "The workbook you want to overwrite is currently open. Choose a different name, or close the workbook before saving.", vbExclamation
isValidName = False
isFileClosed = False
Else
isFileClosed = True
End If
Loop
'Check if an opened workbook has the same name
If isWorkbookOpen(strFilename) Then
MsgBox "You cannot save this workbook with the same name as another open workbook or add-in. Choose a different name, or close the other workbook or add-in before saving.", vbExclamation
isValidName = False
isFileClosed = False
isWorkbookClosed = False
Else
isWorkbookClosed = True
End If
Loop
ThisWorkbook.SaveAs Filename:=strFullFileName, FileFormat:=xlOpenXMLWorkbook
ClosingStatements:
Application.EnableEvents = True
Application.DisplayAlerts = True
Exit Sub
ErrHandler:
Call MsgBox("Run-time error '" & Err.Number & "': " & Err.Description & vbNewLine & _
"While running: " & C_PROC_NAME & IIf(Erl <> 0, vbNewLine & "Error Line: " & Erl, "")
GoTo ClosingStatements
End Sub
Function isFileOpen(ByVal Filename As String) As Boolean
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open Filename For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: isFileOpen = False
Case 70: isFileOpen = True
End Select
End Function
Function isWorkbookOpen(ByVal Filename As String) As Boolean
Dim wb As Workbook, ErrNo As Long
On Error Resume Next
Set wb = Workbooks(Filename)
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: isWorkbookOpen = True
Case Else: isWorkbookOpen = False
End Select
End Function
Explanation of part 1: This whole thing might seem a bit overkill, but all the error handling is important here to take into account potential errors and make sure that the setting for Application.EnableEvents is turned back to TRUE even if an error occurs. Otherwise, all event macros will be disabled in your Excel application.
2 - Call the SaveAsCustomWindow procedure inside the Workbook_BeforeSave event procedure like this:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Your code
If ThisWorkbook.Path = "" Then
SaveAsCustomWindow
Cancel = True
End If
End Sub
Note that we need to set the variable Cancel = True in order to prevent the default SaveAs window to show up. Also, the if statement is there to make sure that the custom SaveAs window will only be used if the file has never been saved.
To answer your questions:
Is it possible to prevent this message from appearing?
Yes, using the Application.DisplayAlerts property
Is it possible to have Excel assume that the user wants to continue with a macro-free workbook?
No, you have to write the procedure to save the workbook and bypass the SaveAs excel event and save the workbook using the user input (Path & Filename) with the required format.
The following procedure uses a FileDialog to capture the Path and Filename from the user then saves the file without displaying the warning message.
I have added some explanatory comments nevertheless, let me know of any questions you might have.
Copy these procedures in the ThisWorkbook module:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True 'Prevents repetitive Save
Call Workbook_BeforeSave_ApplySettings_And_Save
End Sub
Private Sub Workbook_BeforeSave_ApplySettings_And_Save()
Dim fd As FileDialog, sFilename As String
Rem Sets FileDialog to capture user input
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.InitialView = msoFileDialogViewDetails
.Title = vbNullString 'Resets default value in case it was changed
.ButtonName = vbNullString 'Resets default value in case it was changed
.AllowMultiSelect = False
If .Show = 0 Then Exit Sub 'User pressed the Cancel Button
sFilename = .SelectedItems(1)
End With
With ThisWorkbook
Do While .Connections.Count > 0
.Connections.Item(.Connections.Count).Delete
Loop
Application.EnableEvents = False 'Prevents repetition of the Workbook_BeforeSave event
Application.DisplayAlerts = False 'Prevents Display of the warning message
On Error Resume Next 'Prevents Events and Display staying disable in case of error
.SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbook 'Saves Template as standard excel using user input
If Err.Number <> 0 Then
MsgBox "Run-time error " & Err.Number & String(2, vbLf) _
& Err.Description & String(2, vbLf) _
& vbTab & "Process will be cancelled.", _
vbOKOnly, "Microsoft Visual Basic"
End If
On Error GoTo 0
Application.DisplayAlerts = True
Application.EnableEvents = True
End With
End Sub

VBA script that maps https to \\ paths for downloads

I wrote a script to download files using VBA. The VBA script has to download items that start with https://collaboration.company.corp/collrooms/specificfolder or with \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder
The specific folders are the same.
If I allow the script to select the specific mapping, it will only recognize it if I use the definition \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder
How can I create a mapping in VBA to tell Excel that https://collaboration.company.corp/collrooms/specificfolder and \collaboration.company.corp#SSL\DavWWWRoot\collrooms\specificfolder is the same and that the first specification is also valid?
My code:
Option Explicit
Sub FolderSelection()
'Shows the folder picker dialog in order the user to select the folder
'in which the downloaded files will be saved.
Dim FoldersPath As String
'Show the folder picker dialog.
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder to save your files..."
.Show
If .SelectedItems.Count = 0 Then
Sheets("Main").Range("B4") = "-"
MsgBox "You did't select a folder!", vbExclamation, "Canceled"
Exit Sub
Else
FoldersPath = .SelectedItems(1)
End If
End With
'Pass the folder's path to the cell. HERE I AM MISSING THE MAPPING. It will show files starting with https if selected and not transfer it to the other structure.
Sheets("Main").Range("B4") = FoldersPath
End Sub
Sub Clear()
'Clears the URLs, the result column and the folder's path.
Dim LastRow As Long
'Find the last row.
With Sheets("Main")
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
'Clear the ranges.
If LastRow > 7 Then
With Sheets("Main")
.Range("C8:D" & LastRow).ClearContents
.Range("B4:D4").ClearContents
.Range("B4").Select
End With
End If
End Sub
and the other part of the download macro is
'Check if the folder exists. I did not check whether it will also download with the https structure?
DownloadFolder = sh.Range("B4")
On Error Resume Next
If Dir(DownloadFolder, vbDirectory) = vbNullString Then
MsgBox "The path is incorrect!", vbCritical, "Folder's Path Error"
sh.Range("B4").Select
Exit Sub
End If
On Error GoTo 0
I tried with a script that I found on Stackoverflow but it does not work
I created an additional module:
Sub test()
Dim dm As New DriveMapper
Dim sharepointFolder As Scripting.Folder
Set sharepointFolder = dm.MapDrive("https://collaboration.company.corp/collrooms/")
' unsure whether I have to add something here and whether this will work with https
Debug.Print sharepointFolder.Path
End Sub
and added the following WebDAV mapping as a new CLASS
Option Explicit
Private oMappedDrive As Scripting.Drive
Private oFSO As New Scripting.FileSystemObject
Private oNetwork As New WshNetwork
Private Sub Class_Terminate()
UnmapDrive
End Sub
Public Function MapDrive(NetworkPath As String) As Scripting.Folder
Dim DriveLetter As String, i As Integer
UnmapDrive
For i = Asc("Z") To Asc("A") Step -1
DriveLetter = Chr(i)
If Not oFSO.DriveExists(DriveLetter) Then
oNetwork.MapNetworkDrive DriveLetter & ":", NetworkPath
Set oMappedDrive = oFSO.GetDrive(DriveLetter)
Set MapDrive = oMappedDrive.RootFolder
Exit For
End If
Next i
End Function
Private Sub UnmapDrive()
If Not oMappedDrive Is Nothing Then
If oMappedDrive.IsReady Then
oNetwork.RemoveNetworkDrive oMappedDrive.DriveLetter & ":"
End If
Set oMappedDrive = Nothing
End If
End Sub
The question is also whether removing the dispose method "Class_Terminate" which unmaps the drive would help? When the class goes out of scope then the drive get's unmapped. And how I could put it all together.

VBA - Saving a workbook without ability to change content

I have a macro which create a copy of a workbook in VBA. I want this copy "Read Only", but the property ReadOnly := True doesn't work.
Here's the code:
The first macro:
Sub SaveXL()
Dim Nom2 As String
Dim Jour2 As String
Dim FPath2 As String
Jour2 = Format(Now(), "yyyymmdd - h\hmm")
Nom2 = Jour2 & " Pricelist"
FPath2 = Sheets("PARAM").Range("B33").Value
On Error GoTo fin4
fichier = Application.GetSaveAsFilename(FPath2 & Nom2, "Fichiers Excel (*.xls), *.xls")
If fichier <> "Faux" Then
ActiveWorkbook.SaveCopyAs fichier
VBA.SetAttr fichier, vbReadOnly
Test GetAName(fichier)
Else
MsgBox "Le fichier n'a pas été enregistré"
End If
Exit Sub
fin4: MsgBox "La création de l'excel a échoué"
End Sub
The second:
Sub Test(targetWorkbookName As String)
Dim F As Integer, C As Integer, derniereligne
Dim targetWorkbook As Workbook
On Error Resume Next
Set targetWorkbook = Workbooks(targetWorkbookName)
On Error GoTo 0
If (targetWorkbook Is Nothing) Then _
Set targetWorkbook = Workbooks.Open(Filename := targetWorkbookName, ReadOnly := True)
For F = 1 To Sheets.Count
ActiveSheet.Select
For C = 15 To 2 Step -1
ActiveSheet.Columns(C).Select
Selection.End(xlDown).Select
derniereligne = ActiveCell.Row
If ActiveSheet.Columns(C).Hidden = True Then
ActiveSheet.Columns(C).Delete
End If
Next C
Next F
Application.DisplayAlerts = False
Sheets("PARAM").Delete
ActiveWorkbook.ActiveSheet.Shapes.Range(Array("Button 2")).Select
Selection.Delete
ActiveWorkbook.ActiveSheet.Shapes.Range(Array("Button 9")).Select
Selection.Delete
targetWorkbook.SaveAs Filename:=targetWorkbookName, FileFormat:=xlOpenXMLWorkbook
End Sub
If you want to make the workbook un-saveable you can do the following instead:
In the ThisWorkbook module use:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Cancel = True
End Sub
Then got to the immediate window (press Ctrl + G) and type:
Application.EnableEvents = False - hit Enter
ThisWorkbook.Save - hit Enter
Application.EnableEvents = True - hit Enter
Now when a user tries to save the workbook it will simply cancel the save, meaning the data can't be permanently overwritten.
ActiveWorkbook.ChangeFileAccess Mode:=xlReadOnly
Read-only is a file system permission not one controlled by Excel
Read-only recommended is the Excel controlled version of it in with the user is prompted to open it as read-only (but they can choose no).
To save a copy of a workbook as read-only recommended you need to: -
Save a copy using SaveCopyAs
Open the copy
Save the copy using SaveAs with the property ReadOnlyRecommended set to true
Delete the previous copy made in the first instruction
Below is a small example of this:-
Public Sub Make_Copy_ReadOnlyRec()
Dim WkBk As Excel.Workbook
'Using SaveCopyAs
ThisWorkbook.SaveCopyAs Environ("UserProfile") & "\Desktop\Temp.xlsm"
'Open the copy
Set WkBk = Application.Workbooks.Open(Environ("UserProfile") & "\Desktop\Temp.xlsm")
'Use save as to make it read only recommended
WkBk.SaveAs Environ("UserProfile") & "\Desktop\Sample.xlsm", XlFileFormat.xlOpenXMLWorkbookMacroEnabled, , , True
'Close the now read only recommended copy
WkBk.Close
Set WkBk = Nothing
'Delete the original copy
Kill Environ("UserProfile") & "\Desktop\Temp.xlsm"
End Sub

Access 2007 Make ACCDE from VBA SysCmd 603

I am trying to automate the tasks I would normally run through to compact my database, save backups, and update revision numbers for an automatic update system I am using. I am stuck on trying to make an accde file with a vba script.
Everything I find pertaining to the subject seems to point to using something like this.
function MakeACCDE(InPath As String, OutPath As String)
Dim app As New Access.Application
app.AutomationSecurity = msoAutomationSecurityLow
app.SysCmd 603, InPath, OutPath
End Function
A few users on various forums claim that this code works for them but I have not had any luck. My database runs the code without errors, but nothing actually happens.
Is there a particular piece of syntax I am not using or maybe something with the format of the file paths?
I found the following code at: http://www.experts-exchange.com/questions/28429044/How-do-I-create-an-Access-2010-accde-from-VBA.html
I inserted into my Access 2010 accdb, ran it, and it created an accde
**UPDATE: Seeing you want to run from a different DB, I tested that also... just change the line 'tmpDB_Full_Name = CurrentProject.FullName' to be your source database
Option Compare Database
Option Explicit
Function Create_MDE()
Dim tmpDB_Full_Name As String
Dim tmpDB_Name As String
Dim tmpDB_Backup_Full_Name As String
Dim tmpCopy_File As Variant
Dim tmpDirectory As String
'Call SetStartupOptions("AllowBypassKey", dbBoolean, False) '---This runs a procedure to deactivate the Shift & F11 key
'tmpDB_Full_Name = CurrentProject.FullName
tmpDB_Full_Name = "C:\data\access\MyDb.accdb"
tmpDirectory = CurrentProject.Path
tmpDB_Name = CurrentProject.Name
tmpDB_Backup_Full_Name = tmpDirectory & "\" & left(tmpDB_Name, Len(tmpDB_Name) - 6) & "-Backup.accdb"
'this removes a file created on the same day
If Dir(tmpDB_Backup_Full_Name) <> "" Then
Kill tmpDB_Backup_Full_Name
End If
'this creates a backup into destination tmpDirectory
If Dir(tmpDB_Backup_Full_Name) = "" Then
Set tmpCopy_File = CreateObject("Scripting.FileSystemObject")
tmpCopy_File.CopyFile tmpDB_Full_Name, tmpDB_Backup_Full_Name, True
End If
Dim app As New Access.Application
app.AutomationSecurity = msoAutomationSecurityLow
app.SysCmd 603, tmpDB_Backup_Full_Name, tmpDirectory & "\" & left(tmpDB_Name, Len(tmpDB_Name) - 9) & ".accde"
'Call SetStartupOptions("AllowBypassKey", dbBoolean, True) '---This runs a procedure to activate the Shift & F11
MsgBox ("Compile Complete!")
End Function
I have prepared a ready-made solution that creates an ACCDE file and at the same time allows you to protect it with a password. With frequent updates, it makes my life so much easier. I tested it on Microsoft Access 2016 and 2019.
The function SaveAccdbAsAccde() performs the following steps:
compiles and saves changes to the database
copies the database to '...(~temp~).ACCDB'
creates the file '...(~temp~).ACCDE'
if everything worked, it sets a password to the database and copies it as the target file
deletes working files
To protect the database with a password, do the following: SaveAccdbAsAccde("password")
I used a few functions that might also come in handy for other tasks:
helper functions based on Scripting.FileSystemObject for handling files use : CopyFile(),DeleteFile(),FileExists()
functions to secure / unsecure the database with a password EncryptDb() and DecryptDb()
All details below:
Option Explicit
'------------------------------------------------------------------------------------
'main function
Public Sub SaveAccdbAsAccde(Optional filePassword As String)
On Error Resume Next
Application.RunCommand acCmdCompileAndSaveAllModules
err.Clear
If err <> 0 Then MsgBox "Save changes in forms and reports before preparing the ACCDE file.": Exit Sub
On Error GoTo err_proc
Dim strFile0 As String, strFile1 As String, strFile2 As String, strFile3 As String
strFile0 = CurrentDb.Name
strFile1 = Replace(CurrentDb.Name, ".accdb", "(~temp~).accdb")
strFile2 = Replace(CurrentDb.Name, ".accdb", "(~temp~).accde")
strFile3 = Replace(CurrentDb.Name, ".accdb", ".accde")
If Not DeleteFile(strFile1) Then MsgBox "Can't felete file: " & strFile2: Exit Sub
If Not CopyFile(strFile0, strFile1) Then MsgBox "Can't copy file: " & strFile0 & " na " & strFile1: Exit Sub
If Not DeleteFile(strFile2) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
MakeACCDESysCmd strFile1, strFile2
If Not FileExists(strFile2) Then MsgBox "Can't create file: " & strFile2: Exit Sub
If Not DeleteFile(strFile3) Then MsgBox "Can't delete file: " & strFile3: Exit Sub
EncryptDb strFile2, strFile3, filePassword
If Not FileExists(strFile3) Then MsgBox "Can't create file: " & strFile3: Exit Sub
If Not DeleteFile(strFile2) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
If Not DeleteFile(strFile1) Then MsgBox "Can't delete file: " & strFile2: Exit Sub
MsgBox "Done: " & strFile3
exit_proc:
Exit Sub
err_proc:
MsgBox err.Description, vbCritical, "Error"
Resume exit_proc
End Sub
'------------------------------------------------------------------------------------
Public Sub EncryptDb(strSourcePath As String, strDestPath As String, pwd As String)
If pwd <> "" Then pwd = ";pwd=" & pwd
DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & pwd, dbVersion167, pwd
End Sub
Public Sub DecryptDb(strSourcePath As String, strDestPath As String, pwd As String)
If pwd <> "" Then pwd = ";pwd=" & pwd
DBEngine.CompactDatabase strSourcePath, strDestPath, dbLangGeneral & ";pwd=", dbVersion167, pwd
End Sub
Public Function MakeACCDESysCmd(InPath As String, OutPath As String)
Dim app As Access.Application
Set app = New Access.Application
app.AutomationSecurity = 1 'msoAutomationSecurityLow - Enables all macros. This is the default value when the application is started.
app.SysCmd 603, InPath, OutPath 'an undocumented action
app.Quit acQuitSaveNone
Set app = Nothing
End Function
'------------------------------------------------------------------------------------
Public Function CopyFile(strFromFile, strToFile)
On Error Resume Next
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
err.Clear
objFSO.CopyFile strFromFile, strToFile, True
CopyFile = err = 0
Set objFSO = Nothing
End Function
Public Function DeleteFile(strFile)
If Not FileExists(strFile) Then DeleteFile = True: Exit Function
On Error Resume Next
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
err.Clear
objFSO.DeleteFile strFile, True
DeleteFile = err = 0
Set objFSO = Nothing
End Function
Public Function FileExists(strFile)
On Error Resume Next
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
FileExists = objFSO.FileExists(strFile)
Set objFSO = Nothing
End Function
I have tested the following code in Access 2016 using ACCDE and ACCDR as the destination file extension:
Dim otherAccess As Access.Application
Set otherAccess = New Access.Application
otherAccess.AutomationSecurity = 1 'msoAutomationSecurityLow
otherAccess.SysCmd 603, InPath, OutPath
otherAccess.Quit acQuitSaveNone
Set otherAccess = Nothing

How to make Excel VBA variables available to multiple macros?

I have a string of macros that call upon each other and refer to workbooks A and B. I want the first macro to prompt the user to select document A and B and these Selections to become the workbook A and B variables I refer to in the various macros.
How do I make the selected documents the referred to variable throughout all the macros?
Thanks in advance!
Declare them outside the subroutines, like this:
Public wbA as Workbook
Public wbB as Workbook
Sub MySubRoutine()
Set wbA = Workbooks.Open("C:\file.xlsx")
Set wbB = Workbooks.Open("C:\file2.xlsx")
OtherSubRoutine
End Sub
Sub OtherSubRoutine()
MsgBox wbA.Name, vbInformation
End Sub
Alternately, you can pass variables between subroutines:
Sub MySubRoutine()
Dim wbA as Workbook
Dim wbB as Workbook
Set wbA = Workbooks.Open("C:\file.xlsx")
Set wbB = Workbooks.Open("C:\file2.xlsx")
OtherSubRoutine wbA, wbB
End Sub
Sub OtherSubRoutine(wb1 as Workbook, wb2 as Workbook)
MsgBox wb1.Name, vbInformation
MsgBox wb2.Name, vbInformation
End Sub
Or use Functions to return values:
Sub MySubroutine()
Dim i as Long
i = MyFunction()
MsgBox i
End Sub
Function MyFunction()
'Lots of code that does something
Dim x As Integer, y as Double
For x = 1 to 1000
'Lots of code that does something
Next
MyFunction = y
End Function
In the second method, within the scope of OtherSubRoutine you refer to them by their parameter names wb1 and wb2. Passed variables do not need to use the same names, just the same variable types. This allows you some freedom, for example you have a loop over several workbooks, and you can send each workbook to a subroutine to perform some action on that Workbook, without making all (or any) of the variables public in scope.
A Note About User Forms
Personally I would recommend keeping Option Explicit in all of your modules and forms (this prevents you from instantiating variables with typos in their names, like lCoutn when you meant lCount etc., among other reasons).
If you're using Option Explicit (which you should), then you should qualify module-scoped variables for style and to avoid ambiguity, and you must qualify user-form Public scoped variables, as these are not "public" in the same sense. For instance, i is undefined, though it's Public in the scope of UserForm1:
You can refer to it as UserForm1.i to avoid the compile error, or since forms are New-able, you can create a variable object to contain reference to your form, and refer to it that way:
NB: In the above screenshots x is declared Public x as Long in another standard code module, and will not raise the compilation error. It may be preferable to refer to this as Module2.x to avoid ambiguity and possible shadowing in case you re-use variable names...
You may consider declaring the variables with moudule level scope.
Module-level variable is available to all of the procedures in that module, but it is not available to procedures in other modules
For details on Scope of variables refer this link
Please copy the below code into any module, save the workbook and then run the code.
Here is what code does
The sample subroutine sets the folder path & later the file path. Kindly set them accordingly before you run the code.
I have added a function IsWorkBookOpen to check if workbook is already then set the workbook variable the workbook name
else open the workbook which will be assigned to workbook variable accordingly.
Dim wbA As Workbook
Dim wbB As Workbook
Sub MySubRoutine()
Dim folderPath As String, fileNm1 As String, fileNm2 As String, filePath1 As String, filePath2 As String
folderPath = ThisWorkbook.Path & "\"
fileNm1 = "file1.xlsx"
fileNm2 = "file2.xlsx"
filePath1 = folderPath & fileNm1
filePath2 = folderPath & fileNm2
If IsWorkBookOpen(filePath1) Then
Set wbA = Workbooks(fileNm1)
Else
Set wbA = Workbooks.Open(filePath1)
End If
If IsWorkBookOpen(filePath2) Then
Set wbB = Workbooks.Open(fileNm2)
Else
Set wbB = Workbooks.Open(filePath2)
End If
' your code here
End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Using Prompt to select the file use below code.
Dim wbA As Workbook
Dim wbB As Workbook
Sub MySubRoutine()
Dim folderPath As String, fileNm1 As String, fileNm2 As String, filePath1 As String, filePath2 As String
Dim filePath As String
cmdBrowse_Click filePath, 1
filePath1 = filePath
'reset the variable
filePath = vbNullString
cmdBrowse_Click filePath, 2
filePath2 = filePath
fileNm1 = GetFileName(filePath1, "\")
fileNm2 = GetFileName(filePath2, "\")
If IsWorkBookOpen(filePath1) Then
Set wbA = Workbooks(fileNm1)
Else
Set wbA = Workbooks.Open(filePath1)
End If
If IsWorkBookOpen(filePath2) Then
Set wbB = Workbooks.Open(fileNm2)
Else
Set wbB = Workbooks.Open(filePath2)
End If
' your code here
End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Private Sub cmdBrowse_Click(ByRef filePath As String, num As Integer)
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Title = "Select workbook " & num
fd.InitialView = msoFileDialogViewSmallIcons
Dim FileChosen As Integer
FileChosen = fd.Show
fd.Filters.Clear
fd.Filters.Add "Excel macros", "*.xlsx"
fd.FilterIndex = 1
If FileChosen <> -1 Then
MsgBox "You chose cancel"
filePath = ""
Else
filePath = fd.SelectedItems(1)
End If
End Sub
Function GetFileName(fullName As String, pathSeparator As String) As String
Dim i As Integer
Dim iFNLenght As Integer
iFNLenght = Len(fullName)
For i = iFNLenght To 1 Step -1
If Mid(fullName, i, 1) = pathSeparator Then Exit For
Next
GetFileName = Right(fullName, iFNLenght - i)
End Function
Create a "module" object and declare variables in there. Unlike class-objects that have to be instantiated each time, the module objects are always available. Therefore, a public variable, function, or property in a "module" will be available to all the other objects in the VBA project, macro, Excel formula, or even within a MS Access JET-SQL query def.