I have an Excel file which checks its local version with the current version from a database. The code to check the version isn't important to the question.
If there's a new version I want to download it, close the old file (because I can't change/modify it while opened), replace it with the new downloaded version and open the downloaded version.
What I have is something like this:
file.xlsm
Private Sub Workbook_Open()
Workbooks.Open ThisWorkbook.Path & "\update.xlsm"
End Sub
update.xlsm
Private Sub Workbook_Open()
Workbooks("file.xlsm").Close
Dim num As Byte
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTPrequest.5")
If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTPrequest.5.1")
On Error GoTo 0
WHTTP.Open "GET", "http://path/file.xlsm", False
WHTTP.Send
num = FreeFile
On Error Resume Next
Open ThisWorkbook.Path & "\file.xlsm" For Binary Access Write As num
If Err.Number <> 0 Then
Workbooks(ThisWorkbook.Path & "\file.xlsm").Close
Open ThisWorkbook.Path & "\File.xlsm" For Binary Access Write As num
End If
On Error GoTo 0
Put num, , WHTTP.ResponseBody
Close num
Workbooks.Open ThisWorkbook.Path & "\file.xlsm"
ThisWorkbook.Close
End Sub
The issue is that since update.xlsm was opened from file.xlsm, once I close file.xlsm, the code from update.xlsm stops running.
I found this thread which is pretty much what I want to do but I couldn't figure out how to get the Application.OnTime working.
Here's where I got the code to download the file.
Edit:
Ok, so I got it almost fully working with the following:
server file.xlsm
Private Sub Workbook_Open()
'Workbooks.Open ThisWorkbook.Path & "\update.xlsm"
End Sub
local file.xlsm
Private Sub Workbook_Open()
Workbooks.Open ThisWorkbook.Path & "\update.xlsm"
End Sub
local update.xlsm
ThisWorkbook:
Private Sub Workbook_Open()
Application.OnTime Now, "test"
End Sub
Module:
Sub test()
Workbooks("file.xlsm").Close
Dim num As Byte
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTPrequest.5")
If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTPrequest.5.1")
On Error GoTo 0
WHTTP.Open "GET", "http://path/file.xlsm", False
WHTTP.Send
num = FreeFile
On Error Resume Next
Open ThisWorkbook.Path & "\file.xlsm" For Binary Access Write As num
If Err.Number <> 0 Then
Workbooks(ThisWorkbook.Path & "\file.xlsm").Close
Open ThisWorkbook.Path & "\File.xlsm" For Binary Access Write As num
End If
On Error GoTo 0
Put num, , WHTTP.ResponseBody
Close num
Workbooks.Open ThisWorkbook.Path & "\file.xlsm"
If Workbooks.Count = 1 Then
Application.Quit
Else
ThisWorkbook.Close
End If
End Sub
The problem I'm getting now is the new downloaded file from the server gets corrupted in some way (it works after the message of Excel repairing the file).
Split the Macro in 2 parts, and use OnTime to trigger the second part first. Here is an example:
Option Explicit
Private Sub Workbook_Open()
On Error GoTo SkipErr
Application.OnTime Now(), "ThisWorkbook.Part2" 'Run as soon other macros finish
Workbooks("file.xlsm").Close
SkipErr:
MsgBox "file.xlsm was not open...", vbCritical
End Sub
Public Sub Part2()
MsgBox "This message will show!", vbInformation
End Sub
Related
I am trying to assign an opened workbook to an workbook object. If that workbook is not already opened, then it throws an error. I am handling the errors using an Error Handler.
This works for me:
On Error GoTo OpenWorkbookError
Set Uwk = Application.Workbooks(WbkName)
OpenWorkbookError:
If Err <> 0 Then
Err.Clear
MsgBox ("Please Open the Required Workbook")
Exit Sub
End If
But is there a way to avoid using the error handlers in this situation.
One way to do it is check each workbook name, but what's wrong with the functions in the link that #SJR gave?
In your provided code you've kept the error handler within the main body of code - it should appear between the Exit Sub and End Sub at the end of the procedure.
Something like this would work without an error handler, but it's slower as it needs to check each workbook:
Sub Test()
Dim Uwk As Workbook
Dim WbkName As String
WbkName = "PERSONAL.XLSB"
For Each Uwk In Workbooks
If Uwk.Name = WbkName Then
Exit For
End If
Next Uwk
If Not Uwk Is Nothing Then
MsgBox Uwk.Name & " found!"
Else
MsgBox "Not found."
End If
End Sub
Your version of the code should have the error handler outside the main body:
Sub Test1()
Dim WbkName As String
Dim UWk As Workbook
WbkName = "PERSONAL1.XLSB"
On Error GoTo OpenWorkbookError
Set UWk = Workbooks(WbkName)
TidyExit:
'Close anything that needs closing and Exit.
Exit Sub '<< End of main body of procedure.
OpenWorkbookError:
Select Case Err.Number
Case 9 'Subscript out of range.
MsgBox "Please open the required workbook."
Resume TidyExit
Case Else
MsgBox "Error " & Err.Number & vbCr & _
Err.Description, vbOKOnly + vbCritical
Resume TidyExit
End Select
End Sub '<< End of procedure.
I can't find where the error is. A similar code to pull dynamic file name worked in another tab.
Sub MonthlyBCRCPL()
Dim filePath As String
Dim CardsRCPLWb As Workbook
Set CardsRCPLWb = ActiveWorkbook
filePath = CardsRCPLWb.Sheets("BCRCPL").Range("A1").Value
'Optimize Code
Call OptimizeCode_Begin
Const FlashFolder As String = "\\apacdfs\SG\GCGR\GROUPS\ASEAN\Dashboard\Cards\Flash\"
Flashname = Format(CardsRCPLWb.Sheets("ASEAN - CARDS, RCPL").Range("C2").Value, "YYYYMMDD")
Flashname = "ASEAN SD Regional Dashboard - " & Flashname & ".xlsx"
Flashpath = FlashFolder & Flashname
Dim FlashWb As Workbook
Set FlashWb = Workbooks.Open(Flashpath)
If FlashWb Is Nothing Then MsgBox "SD Flash File does not exist": Exit Sub
Consider handling the error in the subroutine and have it raise a message. Then, properly continues/skips/exits rest of code even releasing objects from memory caught during the exception. This is a best practice in VBA (and generally in programming).
I suspect the path cannot be found which looks to be a network UNC, file naming is not valid such as use of special characters, or workbook does not exist when trying to open:
Sub MonthlyBCRCPL()
On Error Goto ErrHandle:
...code...
ExitSubBlock:
Set CardsRCPLWb = Nothing
Set FlashWb = Nothing
Exit Sub
ErrHandle:
Msgbox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Goto ExitSubBlock
' Resume Next
End Sub
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.
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
This question has been edited due to lengthy comments and updates from proposed answers.
As requested here is module 13;
Sub SaveInFormat()
Application.DisplayAlerts = False
Workbooks.Application.ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\jammil\Desktop\AutoFinance\ProjectControl\Data\" & Format(Date, "yyyymm") & "DB" & ".xlsx", leFormat:=51
Application.DisplayAlerts = True
End Sub
Also there are issues with the errorhandling, I know I've gone wrong with it but I'm more interested in fixing the close function at the moment before I get into it. Here is the error handling code that needs some work
Sub test()
Dim wk As String, yr As String, fname As String, fpath As String
Dim owb As Workbook
wk = ComboBox1.Value
yr = ComboBox2.Value
fname = yr & "W" & wk
fpath = "C:\Documents and Settings\jammil\Desktop\AutoFinance\ProjectControl\Data"
owb = Application.Workbooks.Open(fpath & "\" & fname)
On Error GoTo ErrorHandler:
ErrorHandler:
If MsgBox("This File Does Not Exist!", vbRetryCancel) = vbCancel Then Exit Sub Else Call Clear
'Do Some Stuff
Call Module13.SaveInFormat
owb.Close
this is your test code plus my changing of the file path and name
After discussion posting updated answer:
Option Explicit
Sub test()
Dim wk As String, yr As String
Dim fname As String, fpath As String
Dim owb As Workbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
wk = ComboBox1.Value
yr = ComboBox2.Value
fname = yr & "W" & wk
fpath = "C:\Documents and Settings\jammil\Desktop\AutoFinance\ProjectControl\Data"
On Error GoTo ErrorHandler
Set owb = Application.Workbooks.Open(fpath & "\" & fname)
'Do Some Stuff
With owb
.SaveAs fpath & Format(Date, "yyyymm") & "DB" & ".xlsx", 51
.Close
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
ErrorHandler: If MsgBox("This File Does Not Exist!", vbRetryCancel) = vbCancel Then
Else: Call Clear
End Sub
Error Handling:
You could try something like this to catch a specific error:
On Error Resume Next
Set owb = Application.Workbooks.Open(fpath & "\" & fname)
If Err.Number = 1004 Then
GoTo FileNotFound
Else
End If
...
Exit Sub
FileNotFound: If MsgBox("This File Does Not Exist!", vbRetryCancel) = vbCancel Then
Else: Call Clear
I'll try and answer several different things, however my contribution may not cover all of your questions. Maybe several of us can take different chunks out of this. However, this info should be helpful for you. Here we go..
Opening A Seperate File:
ChDir "[Path here]" 'get into the right folder here
Workbooks.Open Filename:= "[Path here]" 'include the filename in this path
'copy data into current workbook or whatever you want here
ActiveWindow.Close 'closes out the file
Opening A File With Specified Date If It Exists:
I'm not sure how to search your directory to see if a file exists, but in my case I wouldn't bother to search for it, I'd just try to open it and put in some error checking so that if it doesn't exist then display this message or do xyz.
Some common error checking statements:
On Error Resume Next 'if error occurs continues on to the next line (ignores it)
ChDir "[Path here]"
Workbooks.Open Filename:= "[Path here]" 'try to open file here
Or (better option):
if one doesn't exist then bring up either a message box or dialogue
box to say "the file does not exist, would you like to create a new
one?
you would most likely want to use the GoTo ErrorHandler shown below to achieve this
On Error GoTo ErrorHandler:
ChDir "[Path here]"
Workbooks.Open Filename:= "[Path here]" 'try to open file here
ErrorHandler:
'Display error message or any code you want to run on error here
Much more info on Error handling here: http://www.cpearson.com/excel/errorhandling.htm
Also if you want to learn more or need to know more generally in VBA I would recommend Siddharth Rout's site, he has lots of tutorials and example code here:
http://www.siddharthrout.com/vb-dot-net-and-excel/
Hope this helps!
Example on how to ensure error code doesn't run EVERYtime:
if you debug through the code without the Exit Sub BEFORE the error handler you'll soon realize the error handler will be run everytime regarldess of if there is an error or not. The link below the code example shows a previous answer to this question.
Sub Macro
On Error GoTo ErrorHandler:
ChDir "[Path here]"
Workbooks.Open Filename:= "[Path here]" 'try to open file here
Exit Sub 'Code will exit BEFORE ErrorHandler if everything goes smoothly
'Otherwise, on error, ErrorHandler will be run
ErrorHandler:
'Display error message or any code you want to run on error here
End Sub
Also, look at this other question in you need more reference to how this works:
goto block not working VBA