VBA Write new file to Program Files folder - vba

i have an xlsm file which is being used by a lot of users, i added an update function which needs to check on a server if a new update of the xlsm file is available, and if its available it needs to download the file, and then overwrite the existing file, some how i get an error write to file failed error 3004 can anyone help me with it?
let me explain my code;
the client xlsm file has a check for new update button, when user clicks that button, here is what happen,
Private Sub CommandButton5_Click()
Dim Answer As VbMsgBoxResult, N%, MyFile$
Answer = MsgBox("1) You need to be on-line to update" & vbLf & _
"2) The update may take a few minutes" & vbLf & _
"3) Please do not interrupt the process once started" & vbLf & _
"" & vbLf & _
"SEARCH FOR UPDATE?", vbYesNo, "Update?")
If Answer = vbNo Then Exit Sub
'otherwise - carry on
Application.ScreenUpdating = False
Application.EnableCancelKey = xlDisabled
On Error GoTo ErrorProcedure
Application.Workbooks.Open ("http://www.mysite.com/Download/Update.xlsm")
'The book on the site opens and you can do whatever you
'want now (note that the remote book is "Read Only") - in
'this particular case a workbook_Open event now triggers
'a procedure to export the new file to the PC
ErrorProcedure:
MsgBox Err.Description
End Sub
and then the update.xlsm from the server opens, and here is the code;
Private Sub workbook_open()
Dim localfile As Date
Dim newfile As Date
localfile = FileDateTime("C:\Documents and Settings\localhost\Desktop\sample.xlsm")
newfile = "6/6/2013 4:00"
If DateDiff("s", localfile, newfile) > 0 Then
MsgBox "its closed"
Application.StatusBar = "contacting the download"
Dim myURL As String
myURL = "http://www.mysite.com/Download/sample.xlsm"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.Send
Application.StatusBar = "waiting for the response"
myURL = WinHttpReq.ResponseBody
If WinHttpReq.Status = 200 Then
Application.DisplayAlerts = False
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
oStream.SaveToFile ("C:\Documents and Settings\localhost\Desktop\sample.xlsm")
oStream.Close
End If
MsgBox "Update Completed"
Application.StatusBar = ""
Windows("Update.xlsm").Activate
ActiveWindow.Close
Application.DisplayAlerts = True
Else
MsgBox "There is no New Update"
Application.StatusBar = ""
End If
End Sub

Writing to %PROGRAMFILES% requires administrative privileges on Windows Vista and above (or XP when running as a limited user). Applications are not supposed to store their data there, and that information has been published for more than a decade now.
A good reference here for information about where to store your application's data is in Does Microsoft have a best practices document regarding the storage of App Data vs User Data on different Windows Platforms?
However, your question is confusing, because you refer to Program Files folder in your subject, but your code uses a hard-coded path to C:\Documents and Settings\localhost\Desktop, which is not the same thing. If that's the actual problem, it's probably because of two issues:
You've hard-coded in C:\Documents and Settings, which is no longer the proper location for user data since Windows Vista was released. You should be using the WinAPI functions that are available to find that folder instead. (Search here at SO for [winapi] SHGetFolderLocation.)
You've hard-coded in the location for the user's Desktop folder, which once again might not be where you think it should be. The same WinAPI function you locate with the search above should be used to find the desktop folder.
It's highly unlikely that localhost has a Desktop folder, even if you were looking in the right place for user documents. localhost is an alias for the IP address 127.0.0.1, and I've never known of a desktop folder for an IP address alias. localhost is not a user on the local machine, and only users can have desktop folders.

Related

Windows Warning Messages for VBA/Sendkeys App

I am trying to do a very simple routine with SendKeys method in VBA to automate opening an app.
The problem is when I try to open a .exe ou .Ink (shortcut) file. The VBA compilation stops and the following message appears "Some files contain viruses that can be harmful to your computer...."
After that I need to select "Ok" or "Cancel" and the aplication doesn't work properly.
I researched a lot but couldn't find any solution. Are there any way to make the message not appear?
I have Windows 10 Home Single Language, Microsoft 365, Excel Version 2107.
See below the code please (The warning message appears in the line "SendKeys (strFile)"):
Sub Ligacao()
Dim strOrigem As String
Dim strExtensao As String
Dim strFile As String
Application.DisplayAlerts = False
strOrigem = ThisWorkbook.Path & "\"
strExtensao = ".lnk"
strFile = Dir(strOrigem & "*" & strExtensao)
Do While strFile <> ""
If Mid(strFile, 1, 3) = "Hat" Then
SendKeys (strFile)
End If
Loop
End Sub

Insert an image file in a MAC Word Userform

I am not a programmer so not sure what to do here. I would like an option of adding an image file in a Microsoft Word document userform for MAC. I had used a code earlier which works perfectly in Windows but it doesnt work for MAC and gives a 5948 error. I had added a field for the image in the userform with a button to add the image and the final submit button. The add button should allow the user to insert any size image from the local folder.
The code I was using is given below:
Dim ImagePath As String
Private Sub CMDAddImage_Click()
Dim objFileDialog As Office.FileDialog
Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)
With objFileDialog
.AllowMultiSelect = False
.ButtonName = "File Picker"
.Title = "File Picker"
If (.Show > 0) Then
End If
If (.SelectedItems.Count > 0) Then
Call MsgBox(.SelectedItems(1))
ImagePath = .SelectedItems(1)
End If
End With
Image1.Picture = LoadPicture(ImagePath)
End Sub
And the code in submit button was:
Dim objWord
Dim objDoc
Dim objShapes
Dim objSelection
'Set objSelection = ActiveDocument.Sections
'objSelection.TypeText (vbCrLf & "One Picture will be inserted here....")
ActiveDocument.Bookmarks("Field04").Select
Set objShapes = ActiveDocument.InlineShapes
objShapes.AddPicture (ImagePath)
End
End Sub
Can someone please help me edit the code for mac. In mac it does not allow to add the file.
You should check out the suggestion made by #JohnKorchok in a comment to your previous question - insert an image Content Control in your document instead, and throw away the VBA.
But if you need to keep using VBA and a UserForm...
Application.FileDialog is not available on Mac.
Application.GetOpenFileName is not avaialble from Word (it's an Excel thing).
Application.Dialogs does not do the same thing as GetOpenFileName so the user experience will be rather different, but at its simplest, you can use it like this:
With Application.Dialogs(wdDialogFileOpen)
' .Display = -1 for "OK" ("Open" in this case)
' .Display = 0 for "Cancel"
' (THere are other possible return values
' but I do not think they are applicable here)
If .Display = -1 Then
ImagePath = .Name
End If
End With
or if you prefer, the lengthier
Dim dlg As Word.Dialog
Set dlg = Application.Dialogs(wdDialogFileOpen)
With dlg
If .Display = -1 Then
ImagePath = .Name
End If
End With
Set dlg = Nothing
However, this dilaog does not let you specify file types or any kind of filtering, a starting folder etc. Attempts to set Finder search criteria via something like
.Name = "(_kMDItemFileName = ""*.jpg"")"
.Update
before the .Display either can't work or need different syntax.
Further, the Apple dialog may start with its
own filtering set up so the user will have to click Options to enable All Files. You don't know what file type the user will choose so you will need to deal with that.
An alternative is to invoke Applescript. For this, it appears that you can still use the VBA MacScript command, which means that you can put all the script in your VBA file. If that does not work, then unfortunately you have to use AppleScriptTask which would require you to work some more on the Script and install the script in the correct folder on every Mac where you need this feature.
Here's the code I used - you would probably need to wrap everything up in another function call and use conditional compilation or other tests to call the correct routine depending on whether the code is running on Mac or Windows
Private Sub CMDAddImage_Click()
Dim s As String
Dim sFileName As String
On Error Resume Next
s = ""
' set this to some other location as appropriate
s = s & "set thePictureFoldersPath to (path to pictures folder)" & vbNewLine
s = s & "set applescript's text item delimiters to "",""" & vbNewLine
s = s & "set theFile to ¬" & vbNewLine
' add the image file types you want here
s = s & "(choose file of type {""png"",""jpg""} ¬" & vbNewLine
s = s & "with prompt ""Choose an image to insert."" ¬" & vbNewLine
s = s & "default location alias thePictureFoldersPath ¬" & vbNewLine
s = s & "multiple selections allowed false) as string" & vbNewLine
s = s & "set applescript's text item delimiters to """"" & vbNewLine
' choose file gives as an AFS path name (with colon delimiters)
' get one Word 2016/2019 will work with
s = s & "posix path of theFile"
sFileName = MacScript(s)
If sFileName <> "" Then
' Maybe do some more validation here
ImagePath = sFileName
Image1.Picture = LoadPicture(ImagePath)
End If
End Sub

Word VBA MkDir Invalid Path in Sharepoint

I am trying to use VBA to create a folder within Sharepoint at my work. The document is opened from Sharepoint so there should be no credential issues (I would think).
I have tried all of the following and always get Run-time error '76': Path not found
How .Path reads the document's location (having removed the document obviously)
MkDir "https://company.sharepoint.com/directory/directory with spaces"
Without certificate
MkDir "//company.sharepoint.com/directory/directory with spaces"
With backslashes between directories
MkDir "https://company.sharepoint.com\directory\directory with spaces"
With corrected spaces
MkDir "https://company.sharepoint.com/directory/directory%20with%20spaces"
and most combinations of the above.
I noted that it takes much longer for Word to decide it's an invalid path without certificate.
I cannot post the actual paths due to NDA issues, but the above recreation should have all pertinent possible issues within the path. I am not parsing the path from variables or input (though I will later) and they are held within a private sub.
I appreciate any help you can give.
Okay, this took me far longer to complete than I expected. I essentially just grabbed the solution from the link in my first comment link I above and added error handling so that (hopefully) all scenarios have a good exit point and explanation.
Sub SharepointAddFolder()
Dim filePath As String
filePath = "https://web.site.com/SharedDocuments/Folder"
'filePath = Replace(filePath, "https:", "") 'I didn't need these but who knows
'filePath = Replace(filePath, "/", "\")
'filePath = Replace(filePath, " ", "%20")
Dim newFolderName As String
newFolderName = "New Folder"
Dim driveLetter As String
driveLetter = "Z:"
Dim ntwk As Object
Set ntwk = CreateObject("WScript.Network")
On Error GoTo ErrHandler
ntwk.MapNetworkDrive driveLetter, filePath, False ', "username", "password"
If Len(Dir(driveLetter & "/" & newFolderName, vbDirectory)) = 0 Then
MkDir driveLetter & "/" & newFolderName
Else
MsgBox "Folder " & newFolderName & " already exists."
End If
ExitThis:
ntwk.RemoveNetworkDrive driveLetter
Exit Sub
ErrHandler:
Select Case Err.Number
Case -2147024829
MsgBox "Sharepoint site not found"
Case 76
'sharepoint directory not found
MsgBox "Mapping failed"
Case -2147024811
'drive already mapped
Resume Next
Case -2147022646
'drive not found and thus cannot be closed
Case -2147022495
MsgBox "This network connection has files open or requests pending." & vbNewLine & vbNewLine & _
"Either close the files or wait until the files are closed, then try to cancel the connection."
Case Else
MsgBox "Error " & Err.Number & ": " & vbNewLine & Err.Description
End Select
End Sub
Note for those of you desiring to continue to work on temporarily mapping SharePoint drives: this code work without any need for username or password (My company uses Authenticator), but only once you have logged in to SharePoint using Internet Explorer. I learned that, when using IE, an option under “All Documents” called “View in File Explorer” exists. It does not exist for Chrome or other browsers (as far as I know). My intent was to permanently map the drives, but once I had logged in from IE the code worked. You do not even have to stay logged in to IE and, when you return to the SharePoint via IE, you are still logged in (I have done this over a one day no-use period). I assume this something to do with the IE being a Microsoft product and therefore being trusted to keep login credentials.

vbscript permission denied 800a0046 network

I made a script that copying a file to a certain location.
I add the .vbs to taskschd.msc scheduled for make a .pst backup
but I get error message
Line: 91
Char: 7
Error: Permission denied
Code: 800A0046
Source: Microsoft VBScript runtime error
<pre>
'Set the amount of pst-files you want to copy. Start counting at 0!
ReDim pst(1)
'Define the location of each pst-file to backup. Increase the counter!
pst(0) = "C:\Users\daniel.elmnas.TT\Documents\Outlook Files\de#teknotrans.se.pst"
pst(1) = "C:\Users\daniel.elmnas.TT\Documents\Outlook Files\de.pst"
'Define your backup location
BackupPath = "\\ttad-1\Gemensam\Outlook_Backup\Daniel Elmnäs"
'Keep old backups? TRUE/FALSE
KeepHistory = FALSE
'Maximum time in milliseconds for Outlook to close on its own
delay = 30000 'It is not recommended to set this below 8000
'Start Outlook again afterwards? TRUE/FALSE
start = TRUE
'===================STOP MODIFY====================================
'Close Outlook
Call CloseOutlook(delay)
'Outlook is closed, so we can start the backup
Call BackupPST(pst, BackupPath, KeepHistory)
'Open Outlook again when desired.
If start = TRUE Then
Call OpenOutlook()
End If
Sub CloseOutlook(delay)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
'If Outlook is running, let it quit on its own.
For Each Process in objWMIService.InstancesOf("Win32_Process")
If StrComp(Process.Name,"OUTLOOK.EXE",vbTextCompare) = 0 Then
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
WScript.Sleep delay
Exit For
End If
Next
'Make sure Outlook is closed and otherwise force it.
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'Outlook.exe'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Set objWMIService = Nothing
Set objOutlook = Nothing
set colProcessList = Nothing
End Sub
Sub BackupPST(pst, BackupPath, KeepHistory)
Set fso = CreateObject("Scripting.FileSystemObject")
If KeepHistory = True Then
ArchiveFolder = Year(Now) & "-" & Month(Now) & "-" & Day(Now)
BackupPath = BackupPath & ArchiveFolder & "\"
End If
If fso.FolderExists(BackupPath) = False Then
fso.CreateFolder BackupPath
End If
For Each pstPath in pst
If fso.FileExists(pstPath) Then
fso.CopyFile pstPath, BackupPath, True
End If
Next
Set fso = Nothing
End Sub
Sub OpenOutlook()
Set objShell = CreateObject("WScript.Shell")
objShell.Run "Outlook.exe"
End Sub
</pre>
Could someone help me to solve this?
Thank you in advance
Seems like you schedule the script.
You need to start the task with a user that executes the script which has rights on the PST file, as well as on the path where you store the backup. Running it with the system account won't be enough.
There are better ways to backup PST files also, I use a Ruby script to synchronise a local copy with a backup copy, is runs on PST's more than 10GB big without problem, might be a problem if you would do it with a copy like this.
You need to backup the copy on a backup medium also because when the PST has errors (and all big PST have) you copy the errors to the backup and could lose both.
Also, you do the following
BackupPath = "\\ttad-1\Gemensam\Outlook_Backup\Daniel Elmnäs"
...
BackupPath = BackupPath & ArchiveFolder & "\"
Where is the \ between the two first variables ?
EDITED: Change the permissions of the folder.
In windows explorer, navigate to the folder where the PST file is located.
In the left pane of windows explorer, right click on the folder where the PST file is located, select "Properties".
Select the "Security" tab
Click the button "Edit" to change permissions.
Click "Add"
In the object names to select box, enter "everyone" (no quotes).
Click "Check Names", everyone should become capitalized and underlined.
Click "Ok"
Select "Everyone" from the list of Groups or user names.
In the "Permissions for Everyone" list, make sure "Read & Execute, List folder contents and Read, in the allow column are checked, click "Apply"
Click Ok.
NOTE: By doing this, anyone who has access to this computer can access the folder. You might consider only adding your login to the computer to the list of Groups or usernames instead of Everyone. You may have to repeat the above steps on the PST file(s) in question.
Original Post:
I ran the script here, testing for various issues and it ran without problems. At this point I believe the issue is rights and permissions to either the source or destination folder (or the files you are backing up). By default, the user's themselves don't have access to Outlooks data files. You would need to add "read" permissions to the files in question (PST,OST, and so on) or the full folder.
In reality, just backing up the PST files isn't enough to restore an Outlook configuration; you would need all of the files.
You can Try this:
'===================================================================
'Description: VBS script to backup your pst-files.
'
'Comment: Before executing the vbs-file, set the location of outlook
' folder you want to backup and
' the backup location (this can also be a network path).
' See the URL below for more configuration instructions and
' how to create a Scheduled Task for it.
'
' Original author : Robert Sparnaaij
' Modified: Fred Kerber
' version: 1.1
' website: http://www.howto-outlook.com/downloads/backupscript.htm
' Changes:
' Changed var types; changed to backup full folder and not just pst files.
'===================================================================
'===================BEGIN MODIFY====================================
'Define the folder location of Outlook's data files.
sOutlookDataPath = "C:\Users\FKerber.CORP\AppData\Local\Microsoft\Outlook\"
'Define your backup location
sBackupPath = "E:\Outlook Backup\"
'Keep old backups? TRUE/FALSE
bKeepHistory = TRUE
'Maximum time in milliseconds for Outlook to close on its own
iDelay = 30000 'It is not recommended to set this below 8000
'Start Outlook again afterwards? TRUE/FALSE
bStart = True
'===================STOP MODIFY====================================
'Close Outlook
Call CloseOutlook(iDelay)
'Outlook is closed, so we can start the backup
Call BackupOutlook(sOutlookDataPath, sBackupPath, bKeepHistory)
'Open Outlook again when desired.
If bStart = TRUE Then
Call OpenOutlook()
End If
Sub CloseOutlook(iDelay)
Set objWMIService = GetObject("winmgmts:" &_
{impersonationLevel= impersonate}!\\.\root\cimv2")
'If Outlook is running, let it quit on its own.
For Each oProcess in objWMIService.InstancesOf("Win32_Process")
If StrComp(oProcess.Name,"OUTLOOK.EXE",vbTextCompare) = 0 Then
Set objOutlook = CreateObject("Outlook.Application")
objOutlook.Quit
WScript.Sleep delay
Exit For
End If
Next
'Make sure Outlook is closed and otherwise force it.
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'Outlook.exe'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Set objWMIService = Nothing
Set objOutlook = Nothing
Set colProcessList = Nothing
End Sub
Sub BackupOutlook(sOutlook, sBackupPath, bKeepHistory)
Set ofso = CreateObject("Scripting.FileSystemObject")
If bKeepHistory = True Then
sArchiveFolder = Year(Now) & "-" & Month(Now) & "-" & Day(Now)
sBackupPath = sBackupPath & sArchiveFolder & "\"
Else
For Each oFile In ofso.GetFolder(sBackupPath).Files
ofso.DeleteFile oFile.Path, True
Next
End If
If ofso.FolderExists(sBackupPath) = False Then
ofso.CreateFolder sBackupPath
End If
For Each oFile In ofso.GetFolder(sOutlook).Files
If ofso.FileExists(oFile.Path) Then
ofso.CopyFile oFile.Path, sBackupPath, True
End If
Next
Set ofso = Nothing
End Sub
Sub OpenOutlook()
Set objShell = CreateObject("WScript.Shell")
objShell.Run "Outlook.exe"
End Sub
I had a similar problem trying to delete files with VBS. I assume that as with my case: The source of the problem is that the script is trying to perform some operation on a file or folder that has a Read-only Attribute. To solve this manually you could left click -> properties -> unclick the Read-Only Attribute then the file/folder should be copied by the script. To solve the problem with VBS: I make the assumption that file/folder is set to Read-Only because there is a programme currently using them.
One: we can just skip files/folders set to read-only this time and hope to get them next time the script runs. For this we first check if file/folder is read-only (I got this from here: https://social.technet.microsoft.com/Forums/ie/en-US/7382d452-1ef9-404a-8874-48d38fcfe911/vbscript-verify-if-a-file-is-readonly?forum=ITCG), if not then we perform the copy operation.
Sub BackupPST(pst, BackupPath, KeepHistory)
'........
For Each pstPath in pst
If fso.FileExists(pstPath) Then
If not (fso.GetFile(pstPath).Attributes AND 1) Then 'if item is not read-only
fso.CopyFile pstPath, BackupPath, True
End If
End If
Next
Set fso = Nothing
End SubSub
Two: At the very least this should prevent you from getting the error. But if the script never moves the files even after running a number of times then chances are that the files (you are trying to move) are always in read only and you should change Attribute of the file (you are trying to move) in your script before calling the copy function, see how to do that here: https://devblogs.microsoft.com/scripting/how-can-i-change-a-read-only-file-to-a-read-write-file/

MS Access: how to compact current database in VBA

Pretty simple question, I know.
If you want to compact/repair an external mdb file (not the one you are working in just now):
Application.compactRepair sourecFile, destinationFile
If you want to compact the database you are working with:
Application.SetOption "Auto compact", True
In this last case, your app will be compacted when closing the file.
My opinion: writting a few lines of code in an extra MDB "compacter" file that you can call when you want to compact/repair an mdb file is very usefull: in most situations the file that needs to be compacted cannot be opened normally anymore, so you need to call the method from outside the file.
Otherwise, the autocompact shall by default be set to true in each main module of an Access app.
In case of a disaster, create a new mdb file and import all objects from the buggy file. You will usually find a faulty object (form, module, etc) that you will not be able to import.
If you have the database with a front end and a back end. You can use the following code on the main form of your front end main navigation form:
Dim sDataFile As String, sDataFileTemp As String, sDataFileBackup As String
Dim s1 As Long, s2 As Long
sDataFile = "C:\MyDataFile.mdb"
sDataFileTemp = "C:\MyDataFileTemp.mdb"
sDataFileBackup = "C:\MyDataFile Backup " & Format(Now, "YYYY-MM-DD HHMMSS") & ".mdb"
DoCmd.Hourglass True
'get file size before compact
Open sDataFile For Binary As #1
s1 = LOF(1)
Close #1
'backup data file
FileCopy sDataFile, sDataFileBackup
'only proceed if data file exists
If Dir(sDataFileBackup, vbNormal) <> "" Then
'compact data file to temp file
On Error Resume Next
Kill sDataFileTemp
On Error GoTo 0
DBEngine.CompactDatabase sDataFile, sDataFileTemp
If Dir(sDataFileTemp, vbNormal) <> "" Then
'delete old data file data file
Kill sDataFile
'copy temp file to data file
FileCopy sDataFileTemp, sDataFile
'get file size after compact
Open sDataFile For Binary As #1
s2 = LOF(1)
Close #1
DoCmd.Hourglass False
MsgBox "Compact complete. " & vbCrLf & vbCrLf _
& "Size before: " & Round(s1 / 1024 / 1024, 2) & "MB" & vbCrLf _
& "Size after: " & Round(s2 / 1024 / 1024, 2) & "MB", vbInformation
Else
DoCmd.Hourglass False
MsgBox "ERROR: Unable to compact data file."
End If
Else
DoCmd.Hourglass False
MsgBox "ERROR: Unable to backup data file."
End If
DoCmd.Hourglass False
Try adding this module, pretty simple, just launches Access, opens the database, sets the "Compact on Close" option to "True", then quits.
Syntax to auto-compact:
acCompactRepair "C:\Folder\Database.accdb", True
To return to default*:
acCompactRepair "C:\Folder\Database.accdb", False
*not necessary, but if your back end database is >1GB this can be rather annoying when you go into it directly and it takes 2 minutes to quit!
EDIT: added option to recurse through all folders, I run this nightly to keep databases down to a minimum.
'accCompactRepair
'v2.02 2013-11-28 17:25
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP#tomparish.me.uk
' http://baldywrittencod.blogspot.com/2013/10/vba-modules-access-compact-repair.html
' DGF Help Contact: see BPMHelpContact module
'=========================================================================
'includes code from
'http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for improved error handling
' v2.02 bugfix preventing Compact when bAutoCompact set to False
' bugfix with "OLE waiting for another application" msgbox
' added "MB" to start & end sizes of message box at end
' v2.01 added size reduction to message box
' v2.00 added recurse
' v1.00 original version
Option Explicit
Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _
, Optional bAutoCompact As Boolean = False) As String
'v2.02 2013-11-28 17:25
'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds
'NB: leaves AutoCompact on Close as False unless specified, then leaves as True
'syntax:
' accSweepForDatabases "path", [False], [True]
'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse":
' accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")]
Application.DisplayAlerts = False
Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single
Dim SizeBefore As Long, SizeAfter As Long
t = Timer
RecursiveDir colFiles, strFolder, "*.accdb", True 'comment this out if you only have Access 2003 installed
RecursiveDir colFiles, strFolder, "*.mdb", True
For Each vFile In colFiles
'Debug.Print vFile
SizeBefore = SizeBefore + (FileLen(vFile) / 1048576)
On Error GoTo CompactFailed
If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes"
acCompactRepair vFile, bAutoCompact
i = i + 1 'counts successes
GoTo NextCompact
CompactFailed:
On Error GoTo 0
j = j + 1 'counts failures
sFails = sFails & vFile & vbLf 'records failure
NextCompact:
On Error GoTo 0
SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)
Next vFile
Application.DisplayAlerts = True
'display message box, mark end of process
accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB"
If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails
MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases"
End Function
Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean
'v2.02 2013-11-28 16:22
'if doEnable = True will compact and repair pthfn
'if doEnable = False will then disable auto compact on pthfn
On Error GoTo CompactFailed
Dim A As Object
Set A = CreateObject("Access.Application")
With A
.OpenCurrentDatabase pthfn
.SetOption "Auto compact", True
.CloseCurrentDatabase
If doEnable = False Then
.OpenCurrentDatabase pthfn
.SetOption "Auto compact", doEnable
End If
.Quit
End With
Set A = Nothing
acCompactRepair = True
Exit Function
CompactFailed:
End Function
'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for error handling
Private Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
On Error Resume Next
strTemp = ""
strTemp = Dir(strFolder & strFileSpec)
On Error GoTo 0
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
On Error Resume Next
strTemp = ""
strTemp = Dir(strFolder, vbDirectory)
On Error GoTo 0
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Private Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
For Access 2013, you could just do
Sendkeys "%fic"
This is the same as typing ALT, F, I, C on your keyboard.
It's probably a different sequence of letters for different versions, but the "%" symbol means "ALT", so keep that in the code. you may just need to change the letters, depending on what letters appear when you press ALT
Letters that appear when pressing ALT in Access 2013
In response to the excellent post by jdawgx:
Please be aware of a flaw in the code for CompactDB() above.
If the database's "AppTitle" property is defined (as happens when an "Application title" is defined in the database properties), this invalidates the "default window title" logic shown, which can cause the script to fail, or "behave unpredictably". So, adding code to check for an AppTitle property - or using API calls to read the Window title text from the Application.hWndAccessApp window could both be much more reliable.
Additionally, in Access 2019, we have observed that:
SendKeys "multi-key-string-here"
... may also not work reliably, needing to be replaced with:
SendKey (single-character)
'put a DoEvents or Sleep 150 here
SendKey (single-character)
'put a DoEvents or Sleep 150 here
SendKey (single-character)
'put a DoEvents or Sleep 150 here
SendKey (single-character)
...to get proper responses from the Access UI.
ALSO for Access 2019:
Sendkeys "%yc" ( <-- works for Access 2016)
is no longer correct.
it is now:
Sendkeys "%y1c"
...and if that little change wasn't enough - try to determine (in code) how to tell the difference between Access 2016 and 2019 - Good Luck!! because
Application.Version alone won't help, and even combining Application.Version and Application.Build is not a guarantee (unless you are in a controlled-release enterprise environment, and then it may work as the possible version/build #s in circulation should be more limited).
Yes it is simple to do.
Sub CompactRepair()
Dim control As Office.CommandBarControl
Set control = CommandBars.FindControl( Id:=2071 )
control.accDoDefaultAction
End Sub
Basically it just finds the "Compact and repair" menuitem and clicks it, programatically.
I did this many years back on 2003 or possibly 97, yikes!
If I recall you need to use one of the subcommands above tied to a timer. You cannot operate on the db with any connections or forms open.
So you do something about closing all forms, and kick off the timer as the last running method. (which will in turn call the compact operation once everything closes)
If you haven't figured this out I could dig through my archives and pull it up.
When the user exits the FE attempt to rename the backend MDB preferably with todays date in the name in yyyy-mm-dd format. Ensure you close all bound forms, including hidden forms, and reports before doing this. If you get an error message, oops, its busy so don't bother. If it is successful then compact it back.
See my Backup, do you trust the users or sysadmins? tips page for more info.
DBEngine.CompactDatabase source, dest
Application.SetOption "Auto compact", False '(mentioned above)
Use this with a button caption: "DB Not Compact On Close"
Write code to toggle the caption with "DB Compact On Close"
along with Application.SetOption "Auto compact", True
AutoCompact can be set by means of the button or by code, ex: after importing large temp tables.
The start up form can have code that turns off Auto Compact, so that it doesn't run every time.
This way, you are not trying to fight Access.
If you don't wish to use compact on close (eg, because the front-end mdb is a robot program that runs continually), and you don't want to create a separate mdb just for compacting, consider using a cmd file.
I let my robot.mdb check its own size:
FileLen(CurrentDb.Name))
If its size exceeds 1 GB, it creates a cmd file like this ...
Dim f As Integer
Dim Folder As String
Dim Access As String
'select Access in the correct PF directory (my robot.mdb runs in 32-bit MSAccess, on 32-bit and 64-bit machines)
If Dir("C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE") > "" Then
Access = """C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE"""
Else
Access = """C:\Program Files\Microsoft Office\Office\MSACCESS.EXE"""
End If
Folder = ExtractFileDir(CurrentDb.Name)
f = FreeFile
Open Folder & "comrep.cmd" For Output As f
'wait until robot.mdb closes (ldb file is gone), then compact robot.mdb
Print #f, ":checkldb1"
Print #f, "if exist " & Folder & "robot.ldb goto checkldb1"
Print #f, Access & " " & Folder & "robot.mdb /compact"
'wait until the robot mdb closes, then start it
Print #f, ":checkldb2"
Print #f, "if exist " & Folder & "robot.ldb goto checkldb2"
Print #f, Access & " " & Folder & "robot.mdb"
Close f
... launches the cmd file ...
Shell ExtractFileDir(CurrentDb.Name) & "comrep.cmd"
... and shuts down ...
DoCmd.Quit
Next, the cmd file compacts and restarts robot.mdb.
Try this. It works on the same database in which the code resides. Just call the CompactDB() function shown below. Make sure that after you add the function, you click the Save button in the VBA Editor window prior to running for the first time. I only tested it in Access 2010. Ba-da-bing, ba-da-boom.
Public Function CompactDB()
Dim strWindowTitle As String
On Error GoTo err_Handler
strWindowTitle = Application.Name & " - " & Left(Application.CurrentProject.Name, Len(Application.CurrentProject.Name) - 4)
strTempDir = Environ("Temp")
strScriptPath = strTempDir & "\compact.vbs"
strCmd = "wscript " & """" & strScriptPath & """"
Open strScriptPath For Output As #1
Print #1, "Set WshShell = WScript.CreateObject(""WScript.Shell"")"
Print #1, "WScript.Sleep 1000"
Print #1, "WshShell.AppActivate " & """" & strWindowTitle & """"
Print #1, "WScript.Sleep 500"
Print #1, "WshShell.SendKeys ""%yc"""
Close #1
Shell strCmd, vbHide
Exit Function
err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Close #1
End Function
Please Note the following - all of you who favor doing a "Compact on Close" solution for MS-Access.
I used to prefer that option too, until one day, when I received the WORST error message possible from the DBEngine during a Compress & Repair operation:
"Table MSysObjects is corrupt - Table Truncated."
Now, you have probably never realized that THAT error is even a possibility.
Well, it is. And if you ever see it, your ENTIRE DATABASE, and EVERYTHING IN IT is now simply GONE. poof!
What is funny about that is that Access will let you actually reopen the "fixed" database, only, the Access window and menu items are all now utterly useless (except to close the DB and exit access again) because ALL the tables (including the other MSYS* tables, forms, queries, reports, code modules, & macros) are simply gone - and with the disk space previously allocated to them released to the tender mercies of the Windows OS - unless you have additional protection than the bog-standard recycle bin, which won't help you either.
So, if you REALLY want to accept the risk of Compact on Close completely clobbering your database - with NO POSSIBILITY of recovering it, then please...do carry on.
If, OTOH, like me you find that risk an unacceptable one, well, don't enable C&R-on-Close - ever again.
Check out this solution VBA Compact Current Database.
Basically it says this should work
Public Sub CompactDB()
CommandBars("Menu Bar").Controls("Tools").Controls ("Database utilities"). _
Controls("Compact and repair database...").accDoDefaultAction
End Sub
There's also Michael Kaplan's SOON ("Shut One, Open New") add-in. You'd have to chain it, but it's one way to do this.
I can't say I've had much reason to ever want to do this programatically, since I'm programming for end users, and they are never using anything but the front end in the Access user interface, and there's no reason to regularly compact a properly-designed front end.