I have found the Macro for MS Word (as below) from the website https://excelchamps.com/blog/vba-code-search-google-chrome/
Sub GoogleSearch()
Dim chromePath As String
Dim search_string As String
Dim query As String
query = InputBox("Please enter the keywords", "Google Search")
search_string = query
search_string = Replace(search_string, " ", "+")
chromePath = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
Shell (chromePath & " -url http://www.google.com/search?hl=en&q=" & search_string)
End Sub
It is expected that:
I press the Macro button, the InputBox pop-out, then I type keywords and it automatically opens Chrome to search those keywords.
If I press the Macro button mistakenly, then I press "Cancel" or "X" to close the Inputbox, Chrome will not automatically open.
I added if msgboxresult = "" then exit sub in the middle of the code. When I open the Inputbox and close it, Chrome doesn't open. But whatever I typed in the Inputbox, Chrome doesn't open and no search is conducted.
Does anyone know what codes should add to it in order to make it End Sub when I don't type anything and close the Inputbox?
Whilst (StrPtr(query) = 0) will indicate that the user pressed cancel it will not catch when the user has left the search term blank and clicked OK.
A better way of writing your routine is to ignore whether the user cancelled and check whether you have a search term to google. Simply checking that query isn't a zero length string before proceeding to launch chrome will catch both eventualities.
Sub GoogleSearch()
Const chromePath As String = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
Dim query As String
query = InputBox("Please enter the keywords", "Google Search")
If Not query = vbNullString Then
query = Replace(query, " ", "+")
Shell (chromePath & " -url http://www.google.com/search?hl=en&q=" & query)
End If
End Sub
I the user to enter a keyword in a text box and when the macro is executed;
Open a new Windows' File Explorer window designated by a path.
path = C:\Users\ME\Desktop\Folder7
Search from the variable in SearchBox1 (this is a ActiveX text box on a worksheet.)
mySearch = sht.OLEObjects("SearchBox1").Object.Text & "*"
I saw multiple posts using Shell commands to open a File Explorer Window.
Call Shell("explorer.exe " & Chr(34) & "search-ms:query=*.pdf&crumb=location:C:\Users\ME\Desktop\Folder7" & Chr(34), vbNormalFocus)
When I run the above line there is an error from the explorer.
'Windows cannot find ". Make sure you typed the name correctly, and then try again.'
I need the macro to search for all files associated with the string. Folder names, file names, and words/characters within each type of document. They have all been OCR'd and Indexed by Windows.
It should have the ability to search for incomplete words as well.
I got Shell to open an explorer window to the path by
Call Shell("explorer.exe " & Chr(34) & "C:\Users\ME\Desktop\Folder7" & Chr(34), vbNormalFocus)
How can I search all folders and sub-folders within this freshly opened window?
I don't need the results compiled into Excel or any other program. I just need to make a quick search button as if you were to manually open this folder and use the search bar.
This worked for me:
Sub Tester()
ShowSearch "C:\_Stuff\test", "*.pdf" 'search by file name
ShowSearch "C:\_Stuff\Mail\", "reminder", True 'search by keyword
End Sub
Sub ShowSearch(searchWhere, searchFor, Optional SearchByKeyword As Boolean = False)
Const CMD As String = "explorer.exe ""search-ms:crumb=name:{query}&crumb=location:{location}"" "
Dim s
s = Replace(CMD, "{query}", WorksheetFunction.EncodeURL(searchFor))
s = Replace(s, "{location}", WorksheetFunction.EncodeURL(searchWhere))
If SearchByKeyword Then s = Replace(s, "crumb=name:", "crumb=")
'Debug.Print s
Shell s
End Sub
Note: WorksheetFunction.EncodeURL() is 2013 and later. For alternatives see:
How can I URL encode a string in Excel VBA?
Double Click on Cell to search
This is a solution I have combined from various places to open an explorer window at a path, that are filtered (searched) by the term in the selected cell using the windows File Explorer search function. It is triggered by a double click on a cell that contains the search term:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Range("A1:AA1048576")) Is Nothing Then
Dim d As String
Dim searchpath As String
Dim searchlocation As String
Cancel = True
d = Selection.Value
'change window name to make sure new explorer window is opened for each instance
'copy string from manual search
searchpath = "search-ms:displayname=" & d & "%20Results%20&crumb=System.Generic.String%3A"
'copy string from manual search (e.g. my documents replace USERNAME)
searchlocation = "&crumb=location:C%3A%5CUsers%5CUSERNAME%5CDocuments"
If Not d = "" Then
Call Shell("explorer.exe """ & searchpath & d & searchlocation & "", 1)
'src: https://stackoverflow.com/questions/24376850/open-explorer-search-from-excel-hyperlink
End If
End If
End Sub
This opens the window in VbNormalFocus, with the window title set to the cell variable (d). The ensures that if this code is run on another cell value a new separate window will be opened. Without this I found the next time I ran the code the explorer window was not updated with the new search value, but just changed focus to the previous result.
edit: "copy from search bar" is the string after location: in the address bar of a manual search in explorer
Using ActiveX Controls
Add an ActiveX Text box (TextBox1) and button (CommandButton1) and add the following codeto the command button:
Private Sub CommandButton1_Click()
Dim d As String
Dim searchpath As String
Dim searchlocation As String
Cancel = True
d = TextBox1.Value
'change window name to make sure new explorer window is opened for each instance
'copy string from manual search
searchpath = "search-ms:displayname=" & d & "%20Results%20&crumb=System.Generic.String%3A"
'copy string from manual search (e.g. my documents replace USERNAME)
searchlocation = "&crumb=location:C%3A%5CUsers%5CUSERNAME%5CDocuments"
If Not d = "" Then
Call Shell("explorer.exe """ & searchpath & d & searchlocation & "", 1)
'src: https://stackoverflow.com/questions/24376850/open-explorer-search-from-excel-hyperlink
End If
End Sub
Now the user can change the text in the text box and clicking the button will open a windows file explorer search of the designated folder in the code.
Screenshot example using button search for "Editable Search Text"
EDIT
You can include additional search functions with the Windows search syntax:
http://download.microsoft.com/download/8/1/7/8174a74e-3d8d-4478-abc6-84cd51ad93c4/Windows_Desktop_Advanced_Query_Reference.pdf
Eg. you can search within the folder for all files with a partial match of each word in the string by changing the search variable "d:
...
d = Selection.Value
d = "(" & Replace(d, " ", " OR ") & ")"
...
if the selection (d) had a value of Where will I find it
This will search for (Where OR will OR I OR find OR it) in windows explorer and would return files with names such as WHEREver and Last WILL and testament. I've found this useful for qualitative information, where casting a wider search is acceptable and can be easily filtered through by the user (NOTE: the above example would also return all files with a name containing i so it is not very specific!)
executing Dir() empty after a Dir() with a given path will start to list all files in that dir, you just use if InStr() <> 0 to check against your value.
sFileName = Dir(path)
Do While sFileName > ""
tmp = tmp & sFileName & ";" : sFileName = Dir()
Loop
List() = Split(tmp, ";")
there you have a list of all files inside that path, you can check sub folders the same way by going through each one doing the same thing.
I do not take credit for the idea, it's awesome that you can do this. I just took the idea a step further and made it modular, so you can add any type of search:
Sub searchInExplorer_TEST()
'searchInExplorer "D:\", , , True, "*.jpg", True, "24 Feb 20"
searchInExplorer "D:\", , , , , True, "24 Feb 20", True, "picture"
End Sub
Sub searchInExplorer(searchWhere _
, Optional isSearchAll As Boolean, Optional strAll _
, Optional isSearchName As Boolean, Optional strName _
, Optional isSearchModified As Boolean, Optional strModified _
, Optional isSearchType As Boolean, Optional strType)
'*****************************************************
'https://stackoverflow.com/questions/52671500/vba-to-open-file-explorer-and-search-for-variable-in-textbox
'ALLOWS SEARCHING IN WINDOWS EXPLORER USING VARIABLES
'EITHER USE SEARCH ALL OR OTHER SEARCH TIMES
'EACH SEARCH TYPE HAS AN ON/OFF SWITCH AND A STRING VARIABLE TO SEARCH BY
'*****************************************************
Dim STR As String
STR = "explorer.exe ""search-ms:"
If isSearchAll Then
STR = STR & "crumb=:" & WorksheetFunction.EncodeURL(strAll)
Else
If isSearchName Then
STR = STR & "&crumb=name:" & WorksheetFunction.EncodeURL(strName)
End If
If isSearchModified Then
STR = STR & "&crumb=modified:" & WorksheetFunction.EncodeURL(strModified)
End If
If isSearchType Then
STR = STR & "&crumb=kind:" & WorksheetFunction.EncodeURL(strType)
End If
End If
STR = STR & "&crumb=location:" & WorksheetFunction.EncodeURL(searchWhere)
STR = STR & """ "
Debug.Print STR
Shell STR
End Sub
In MS Access I want to print a preselection of pages but I want the user to select the output printer.
I already tried the PrintOut and acCmdPrint commands but I want a mix of them.
If I use the PrintOut command I have the option to set in the parameters the page range but the dialog box doesn't show up and the document gets printed to the default printer. Can´t give the option to select the printer this way.
If I use the acCmdPrint command I do't have an option to preselect the pages. The range of the full document appears in the page selection (ex 1 to final page) and I want to select 1 to 3 or 5 to 9 instead of 1 to final page. The good part is that user gets the option to select the printer this way.
Printer and page selection? Any help? Thanks.
Maybe you can try to do the following: Just do a print preview rather than a print, then while viewing the report, the user should be able to select File, Print..., which will bring up the options he wants like page range.
DoCmd.OpenReport "report", acViewPreview
DoCmd.RunCommand acCmdPrint
Update 1: You can invoke a printer selection dialog using xlDialogPrinterSetup
Dim myprinter As String
' Back up default printer.
myprinter = Application.ActivePrinter
' Let the user select a printer.
If Application.Dialogs(xlDialogPrinterSetup).Show Then
' Print to the selected printer
cmd.PrintOut Preview:=False, ActivePrinter:=Application.ActivePrinter
End If
' Restore original printer.
Application.ActivePrinter = myprinter
Update 2: Ok, If it is Access it seems that xlDialogPrinterSetup it is not available. One option is that you can create your own Print Dialog Form using the following code that lists all the available printers. The code was taken from this link.
Sub ShowPrinters()
Dim strCount As String
Dim strMsg As String
Dim prtLoop As Printer
On Error GoTo ShowPrinters_Err
If Printers.Count > 0 Then
' Get count of installed printers.
strMsg = "Printers installed: " & Printers.Count & vbCrLf & vbCrLf
' Enumerate printer system properties.
For Each prtLoop In Application.Printers
With prtLoop
strMsg = strMsg _
& "Device name: " & .DeviceName & vbCrLf _
& "Driver name: " & .DriverName & vbCrLf _
& "Port: " & .Port & vbCrLf & vbCrLf
End With
Next prtLoop
Else
strMsg = "No printers are installed."
End If
' Display printer information.
MsgBox Prompt:=strMsg, Buttons:=vbOKOnly, Title:="Installed Printers"
ShowPrinters_End:
Exit Sub
ShowPrinters_Err:
MsgBox Prompt:=Err.Description, Buttons:=vbCritical & vbOKOnly, _
Title:="Error Number " & Err.Number & " Occurred"
Resume ShowPrinters_End
End Sub
You only need to adapt that code to fill a listbox in your own print dialog form. And then, when the user selects one of the printers, you can do the following:
Dim oldPrinter As Printer
' Save original printer.
Set oldPrinter = Application.Printer
' x is the list index of the selected printer of your form.
Application.Printer = Application.Printers.Item(x)
' Print the report here using PrintOut.
' Restore the printer.
Application.Printer = oldPrinter
I'm not sure if this is more appropriate under a different SE site (Super User?).
I want to build and sell a complex macro driven driven spreadsheet to a certain vertical. I am mainly concerned about free/unauthorised distribution between customers within that vertical.
I can see that there is a few obscure products on the market that might be able to do what I want, but the few reviews that i've been able to find haven't been favourable.
One vendor however lists that free distribution can circumvented by either:
Using a key generator to create license codes
Using the online activation feature
Or by simply using an encrypted password
Is anyone aware of any guidelines/frameworks (any language) for me to build my own solution to achieve this, namely requiring licence codes or online activation?
If this is generally a difficult endeavour, is there a commercial product that anyone recommend?
I'm also thinking the complexities involved in achieving this might push me to building a small SaaS application instead. Am I better off just going that route?
I have created an Excel sheet that I could remotely remove access to if a monthly subscription payment failed. Here is how to accomplish this:
Create and HTML table and upload it to your website
Within your Excel doc go to the data tab and select get from web - import your table into a sheet called "Verify" - make sure your table has 3 columns. Serial Number is in the first column, description of user in 2nd, and your error message in the top of col 3. The error message stored here is what every user that isn't registered will see. The first serial number should appear in cell A2 of the sheet Verify.
Within your Visual Basic editor paste this code into a Module - This code will return an 8 digit serial number based on a PC's Hard Drive serial number:
Function HDSerialNumber() As String
Dim fsObj As Object
Dim drv As Object
Set fsObj = CreateObject("Scripting.FileSystemObject")
Set drv = fsObj.Drives("C")
HDSerialNumber = Left(Hex(drv.SerialNumber), 4) _
& "-" & Right(Hex(drv.SerialNumber), 4)
End Function
Also in another module I make sure the Internet is connected. If no Internet then the sheet closes. If you don't do this then if someone disconnects from the Internet your serials won't be loaded.
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function InternetGetConnectedStateEx Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
#Else
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
#End If
Function IsInternetConnected() As Boolean
Dim strConnType As String, lngReturnStatus As Long, MyScript As String
If Application.OperatingSystem Like "*Macintosh*" Then
MyScript = "repeat with i from 1 to 2" & vbNewLine
MyScript = MyScript & "try" & vbNewLine
MyScript = MyScript & "do shell script ""ping -o -t 2 www.apple.com""" & vbNewLine
MyScript = MyScript & "set mystatus to 1" & vbNewLine
MyScript = MyScript & "exit repeat" & vbNewLine
MyScript = MyScript & "on error" & vbNewLine
MyScript = MyScript & "If i = 2 Then set mystatus to 0" & vbNewLine
MyScript = MyScript & "end try" & vbNewLine
MyScript = MyScript & "end repeat" & vbNewLine
MyScript = MyScript & "return mystatus"
If MacScript(MyScript) Then IsInternetConnected = True
Else
lngReturnStatus = InternetGetConnectedStateEx(lngReturnStatus, strConnType, 254, 0)
If lngReturnStatus = 1 Then IsInternetConnected = True
End If
End Function
Then inside the Workbook_Open area paste this:
Private Sub Workbook_Open()
If IsInternetConnected Then
Dim objFSO As Object
Dim MyFolder As String
Dim sFileName As String
Dim iFileNum As Integer
Dim sBuf As String
Dim trialstartdate As String
Dim z As String
Dim fsoFSO
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
'UNCOMMENT below to SHOW the serials sheet when the workbook is opened
ActiveWorkbook.Sheets("Verify").Visible = xlSheetVisible
'UNCOMMENT below to hide the serials sheet when the workbook is opened
'ActiveWorkbook.Sheets("Verify").Visible = xlSheetVeryHidden
Refresh_Serials
z = 2
'loop here for valid hard drive serial number
Do Until IsEmpty(Worksheets("Verify").Cells(z, 1).Value)
If Worksheets("Verify").Cells(z, 1).Value = HDSerialNumber Then
'verified and let pass
GoTo SerialVerified
End If
z = z + 1
Loop
Dim custommessage As String
custommessage = Worksheets("Verify").Cells(2, 3)
MsgBox custommessage + " Your serial number is: " + HDSerialNumber
Dim wsh1, MyKey1
Set wsh1 = CreateObject("Wscript.Shell")
MyKey1 = "%{TAB}"
wsh1.SendKeys MyKey1
MsgBox "The Commission Tracker will not open without a valid serial number. It will now close. uncomment this in workbook->open to close the workbook if the serial isn't found"
Application.DisplayAlerts = False
'uncomment this to close the workbook if the serial isn't found
'ActiveWorkbook.Close
Application.DisplayAlerts = True
SerialVerified:
' does the end user agree to not use this tool for mailicous purposes?
MsgAgree = MsgBox("Your PC's serial number is " & HDSerialNumber & ". By clicking 'Yes' you agree to use our software as described in our end user agreement. - the URL to your terms here", vbYesNo, "Final Agreement")
If MsgAgree = vbNo Then
'close program
MsgBox "This program will now close since you do not agree to our end user agreement"
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Else
'continue to open the program
End If
Else
MsgBox "No Network Connection Detected - You must have an internet connection to run the commission tracker."
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End If
End Sub
That should do it....
Create your own special unique license keys in a macro that will unlikely be generated in a key generator. Add your own prefix, for example. You could store if a user is using it in an online database. Downfall to this solution is that the users would have to be connected to the outside internet.
Then lock down that module with the keys by the following:
To protect your code, open the Excel Workbook and go to Tools>Macro>Visual Basic Editor (Alt+F11). Now, from within the VBE go to Tools>VBAProject Properties and then click the Protection page tab and then check "Lock project from viewing" and then enter your password and again to confirm it. After doing this you must save, close & reopen the Workbook for the protection to take effect.
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.