Issue while running exe from VBS script using Nsclient - authentication

I have written a vbs script for the intel cpu vulnerability which runs completely OK when I run it manually from command line or by double clicking it.
We have an NSClient/git infra across all servers which is used by nagios to create checks and I am trying to execute this script using NSClient++.exe from command prompt. However, when I run the file using NSClient it fails to create the log file(SA-00086--).
Here is my NSClient command from nsc.ini:
intel_cpu_vulnerability=C:\Windows\system32\cscript.exe //NoLogo //T:60 C:\WINDOWS\NSClient\scripts\DiscoveryTool\cpu-unsafe.vbs
Here is my cpu-unsafe.vbs Script:
' VB SCript to find the Intel Processor vulnerability.
Dim Maindir, objFSO, oFile, Executable, Vulnerable, NotVulnerable, objTextFile, Readme, VStatus, StatusLine, strLine
Const ForReading = 1
Maindir = "c:\Windows\nsclient\scripts\DiscoveryTool"
Executable = "Intel-SA-00086-console.exe"
Vulnerable = "Status: This system is vulnerable."
NotVulnerable = "Status: This system is not vulnerable."
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
'Deleting all previous log/xml files
For Each oFile In objFSO.GetFolder(Maindir).Files
If LCase(objFSO.GetExtensionName(oFile.Name))= "log" or LCase(objFSO.GetExtensionName(oFile.Name)) = "xml" Then
If oFile.Name <> "CommandLine.xml" Then
Deleteme = Maindir+"\"+oFile
objFSO.DeleteFile oFile
End If
End If
next
'Running the Intel detector
WSHShell.Run Maindir + "\" + Executable , 0, True
Set objShell = Nothing
WScript.Sleep 3000
'Setting the logfile to read
For Each oFile In objFSO.GetFolder(Maindir).Files
If LCase(objFSO.GetExtensionName(oFile.Name))= "log" Then
If oFile.Name <> "CommandLine.xml" Then
Readme = oFile
End If
End If
next
Set objTextFile = objFSO.OpenTextFile(Readme, ForReading)
'Reading the logfile and determining if the prosessor is affected.
VStatus = "Undetermined"
do until objTextFile.AtEndOfStream
strLine = objTextFile.ReadLine()
If Left(strLine, 7) = "Status:" Then
If InStr(strLine, NotVulnerable) <> 0 then
VStatus = "OK"
StatusLine = strLine
End If
If InStr(strLine, Vulnerable) <> 0 then
VStatus = "NOK"
StatusLine = strLine
End If
End If
If Left(strLine, 24) = "Status: Detection Error:" Then
VStatus = "Undetermined"
StatusLine = strLine
End If
loop
'The FINAL RESULTS:
If VStatus = "OK" then
Wscript.Echo VStatus + ": Not Vulnerable -> From File: " + StatusLine
Wscript.Quit(1)
ElseIf VStatus = "NOK" then
Wscript.Echo VStatus + ": Vulnerable -> From File: " + StatusLine
Wscript.Quit(3)
Else
Wscript.Echo VStatus + ": May be Vulnerable -> From File: " + StatusLine
Wscript.Quit(2)
End If
objTextFile.Close
To test this script you have to download Windows Vulnerability Detection tool from Intel's Website. Once downloaded, extract the zip file and place this script inside DiscoveryTool Folder and run it by double clicking. The script will tell if your cpu is affected by the IntelĀ® Management Engine vulnerability.
Edit: I further tried executing the .exe directly from the NSClient and it gave me Commandline.dll auth fail error.
nsc.ini command:
icvy=C:\WINDOWS\NSClient\scripts\DiscoveryTool\Intel-SA-00086-console.exe
Output:
l NSClient++.cpp(456) Enter command to inject or exit to terminate...
icvy
d NSClient++.cpp(1106) Injecting: icvy:
e \CheckExternalScripts.cpp(188) The command (C:\WINDOWS\NSClient\scripts\DiscoveryTool\Intel-SA-00086-console.exe) retu
rned an invalid return code: 11
d NSClient++.cpp(1142) Injected Result: WARNING 'Error: The file 'CommandLine.dll' authentication has failed.'
d NSClient++.cpp(1143) Injected Performance Result: ''
WARNING:Error: The file 'CommandLine.dll' authentication has failed.

Try setting the current working directory to the directory containing the executable. I was seeing the same error message until I did so. In VBScript, I gather that would look something like:
WSHShell.CurrentDirectory = Maindir
WSHShell.Run Maindir + "\" + Executable , 0, True

Related

Check right installation of 7-Zip (64 / 32bit)

My goal is avoid error msg from VBA debugger. Need to check which version of 7-zip have installed, program files/ or program files (x86):
Trying do simple "IF" function.
Dim PathZipProgram As String
strCommand As String
PathZipProgram = "C:\Program Files(x86)\7-Zip\7z.exe"
If Right(PathZipProgram, 1) Then
PathZipProgram = PathZipProgram
Else
PathZipProgram = "C:\Program Files\7-Zip\7z.exe"
End If
Shell strCommand
strCommand = """" & PathZipProgram & """ a -tzip """
VBA cant find 7zip.
You can check if the file exist with a function like this:
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
TestStr = ""
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
If TestStr = "" Then
FileExists = False
Else
FileExists = True
End If
End Function
And then use it in your code:
Dim PathZipProgram As String
Dim strCommand As String
PathZipProgram = "C:\Program Files(x86)\7-Zip\7z.exe"
If Not FileExists(PathZipProgram) Then
PathZipProgram = "C:\Program Files\7-Zip\7z.exe"
End If
Shell strCommand
strCommand = """" & PathZipProgram & """ a -tzip """
Hope this help as a starting point.
Installation Path: 7-Zip could be installed in another disk location (for example the D: drive, or somewhere else). You do
need to read the paths from the registry to be sure. A couple of
suggestions below:
1. Hacky Version
I have put a full script below to use, but you can essentially get what you want the hacky way (make sure the paths actually exists - obviously - maybe use "C:\Program Files\7-Zip" if there are problems seen):
Check File Exists:
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FileExists("C:\Program Files (x86)\7-Zip\7z.exe")) Then
' Do Stuff
End If
Get File Version:
Set fso = CreateObject("Scripting.FileSystemObject")
MsgBox fso.GetFileVersion("C:\Program Files (x86)\7-Zip\7z.exe")
Don't rely on this please. It will fail eventually. Please see below.
2. Full Version
Here is a full version, the steps you need to make something that has a hope to be reliable. Essentially read paths from registry and take it from there:
Const HKEY_LOCAL_MACHINE = &H80000002 : strComputer = "."
Set fso = CreateObject("Scripting.FileSystemObject")
Set reg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\default:StdRegProv")
' 64-bit - Read 7-zip installation path from registry
regpath64 = "SOFTWARE\7-Zip"
reg.GetStringValue HKEY_LOCAL_MACHINE, regpath64, "Path64", regvalue64
fullpath64 = regvalue64 + "\" + "7z.exe"
If (fso.FileExists(fullpath64)) Then
MsgBox "7-zip 64-bit: " + fso.GetFileVersion(fullpath64), vbOKOnly, "64-bit:"
End If
' 32-bit - Read 7-zip installation path from registry
regpath32 = "SOFTWARE\WOW6432Node\7-Zip"
reg.GetStringValue HKEY_LOCAL_MACHINE, regpath32, "Path", regvalue32
fullpath32 = regvalue32 + "\" + "7z.exe"
If (fso.FileExists(fullpath32)) Then
MsgBox "7-zip 32-bit: " + fso.GetFileVersion(fullpath32), vbOKOnly, "32-bit:"
End If
Disclaimer: For the 64-bit registry read: there could be a Path and a Path64 entry
(I have both). Not sure what earlier and / or later versions will
have. Please check.

How to change an FTP upload VBScript to SFTP

I want to change this to the SFTP server. How should I update this following script?
'FTP Upload
'Upload a file/folder to an FTP server
Set oShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFSO
Varnow = now
vardate = Day(varnow) & "-" & Month(varnow) & "-" & Year(varnow) & ".csv"
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFile = "D:/file.csv"
strRename = "D:/file-" & vardate
If objFSO.FileExists(strFile) Then
objFSO.MoveFile strFile, strRename
End If
'Path to file or folder to upload
path = strRename
FTPUpload(path)
Sub FTPUpload(path)
On Error Resume Next
'Copy Options: 16 = Yes to All
Const copyType = 16
'FTP Wait Time in ms
waitTime = 8000
FTPUser = "ftuser"
FTPPass = "psw"
FTPHost = "hostname"
FTPDir = "/Dir"
strFTP = "ftp://" & FTPUser & ":" & FTPPass & "#" & FTPHost & FTPDir
Set objFTP = oShell.NameSpace(strFTP)
'Upload single file
If objFSO.FileExists(path) Then
Set objFile = objFSO.getFile(path)
strParent = objFile.ParentFolder
Set objFolder = oShell.NameSpace(strParent)
Set objItem = objFolder.ParseName(objFile.Name)
objFTP.CopyHere objItem,copyType
End If
If Err.Number <> 0 Then
Wscript.Echo "Error: " & Err.Description
End If
'Wait for upload
WScript.Sleep waitTime
If objFSO.FileExists(strRename) Then
objFSO.MoveFile strRename, strFile
End If
End Sub
So as you see I want to switch the FTP upload to SFTP upload (because the destination server have been changed to the SFTP protocol. What should be modified exactly in the this function Sub FTPUpload(path) to do so?
Have you any tips to do so?
There's no support for SFTP in FileSystemObject, nor any other way in Windows.
You have to use a 3rd party SFTP command-line client or COM object.
So there's no easy way to change your existing script. You have to basically start from the scratch.
There are lot of existing questions on Stack Overflow for SFTP uploads with VBScript.
You can for example use WinSCP SFTP client. It has both command-line scripting interface and COM object.
Using WinSCP scripting in Windows Scripting host (JScript or VBScript)
Does not require any installation, but it's more difficult to use from VBS.
Using WinSCP .NET assembly/COIM library in Windows Scripting host (JScript or VBScript)
Requires installation (registration), but it's easier to use from VBS.
(I'm the author of WinSCP)

Can't run DIR from WScript Shell in VBA?

I use the following function in a lot of my VBA projects. I initially added the reference to Windows Script Host Object model to take advantage of Intellisense, but then switched to late binding so I didn't have to reference a bunch of stuff.
Private Function RunCMD(ByVal strCMD As String) As String
'Runs the provided command
Dim oShell As Object 'New WshShell
Dim cmd As Object 'WshExec
Dim x As Integer
Const WshRunning = 0
On Error GoTo wshError
x = 0
RunCMD = "Error"
Set oShell = CreateObject("Wscript.Shell")
Set cmd = oShell.Exec(strCMD)
'Debug.Print strCMD
'Stop
Do While cmd.Status = WshRunning
Sleep 100 'for 1/10th of a second
x = x + 1
If x > 1200 Then 'We've waited 2 minutes so kill it
cmd.Terminate
MsgBox "Error: Timed Out", vbCritical, "Timed Out"
End If
Loop
RunCMD = cmd.StdOut.ReadAll & cmd.StdErr.ReadAll
Set oShell = Nothing
Set cmd = Nothing
Exit Function
wshError:
On Error Resume Next
RunCMD = cmd.StdErr.ReadAll
Resume Next
End Function
It works great when you do something like
RunCMD("ping www.bing.com") or
RunCMD("winrs -r:" & strHost & " reg query hklm\system\currentcontrolset\services\cdrom /v start")
However RunCMD("Dir c:\config* /a:-d /b /d /s") fails, and cmd.StdErr.ReadAll gives an Object Variable or With Block not set error. Even a simple RunCMD("Dir") fails.
Why does DIR make the WScript shell crap out? More importantly, how can I use CMD's DIR function (not VBA's DIR function!) to get a list of files that match a search pattern?
Does it work if you preface your dir command with "cmd /c " and wrap your DOS command in double quotes, like
RunCmd("cmd /c ""DIR""")
or
RunCmd("cmd /c ""Dir c:\config* /a:-d /b /d /s""")

How to wait for an application to start in VBScript?

I'm a new VB Script programmer trying to use VB Script to open a pdf file via the default program (Adobe Reader X in this case) and save it as a text file.
The current script I have opens the PDF, waits 1 second, then saves it as text. However, for slower computers, it might take more than 1 second for the PDF to load up. Does anyone know how to do a sleep loop until the file is opened or the status is ready?
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run """C:\Temp\Gasprices.pdf"""
Set objShell = CreateObject("WScript.Shell")
wscript.sleep 1000
objShell.SendKeys "%FAX%S"
First off, since you are a beginner, always use Option Explicit. Many errors are caused by typos in variable names, you will catch them if you force yourself to declare all variables you use.
Secondly, you don't need to create two WScript.Shell objects, just re-use the existing one.
Thirdly, you need to activate the application you want to send commands to. That's what the Shell object's AppActivate method is for. It returns True or False, indicating whether bringing the application in question to the foreground has worked or not. You could use that in a loop (While Not Shell.AppActivate("Adobe Reader") ...) to wait exactly as long as the application needs.
However, the downside is that you need to know the exact title of the application window (or its process ID) for this to work at all. Application titles might change without warning, so this is kind of shaky. The PID is robust but it is not guessable.
In the end you will need the help of WMI to list all processes, fetch the correct PID and then pass that to AppActivate. The Win32_Process class is made for this.
Dim Shell, WMI, pid
Set Shell = WScript.CreateObject("WScript.Shell")
Set WMI = GetObject("winmgmts:!\\.\root\cimv2")
Shell.Run "start ""C:\Temp\Gasprices.pdf"""
pid = WaitForProcess("AcroRd32.exe", 5)
If pid > 0 Then
Shell.AppActivate pid
Shell.SendKeys "%FAX%S"
Else
WScript.Echo "Could not talk to PDF reader"
WScript.Quit 1
End If
Function WaitForProcess(imageName, tries)
Dim wql, process
wql = "SELECT ProcessId FROM Win32_Process WHERE Name = '" & imageName & "'"
WaitForProcess = 0
While tries > 0 And WaitForProcess = 0
For Each process In WMI.ExecQuery(wql)
WaitForProcess = process.ProcessId
Next
If WaitForProcess = 0 Then
WScript.Sleep 1000
tries = tries - 1
End If
Wend
End Function
Note that assigning to the function name (as in WaitForProcess = 0) sets the return value.
You could optimize this by finding the script's own PID and querying
"SELECT ProcessId FROM Win32_Process WHERE ParentProcessId = '" & scriptPID & "'"
in WaitForProcess().
Another possible option would be to test for Process CPU Usage...
You would need to test and see if this works in your environment...
Dim oShell, oExec, PID, X, Z
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec(Chr(34) & "C:\ADOBE PATH" & Chr(34) & " " & Chr(34) & "C:\YOUR PDF PATH.pdf" & Chr(34))
PID = oExec.ProcessID
WScript.Echo PID
'Prevent an Endless Loop
Z = 600 'about one minute worse case
Do
WScript.Sleep 100
X = GetCPUUsage(PID)
WScript.Echo X
Z = Z - 1
If oExec.Status <> 0 Then
MsgBox "The Process has been Terminated. Ending Script"
WScript.Quit
End If
Loop Until X = 0 Or Z = 0
If Z > 0 Then
WScript.Echo "Process Is More Or Less Opened"
Else
WScript.Echo "Process is open... Maybe?"
End If
Function GetCPUUsage(ProcID)
Dim objWMIService, colItems, objItem
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
'Just in case
GetCPUUsage = 0
Set objWMIService = GetObject("winmgmts:\\.\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT PercentProcessorTime FROM Win32_PerfFormattedData_PerfProc_Process WHERE IDProcess = '" & ProcID & "'", _
"WQL", wbemFlagReturnImmediately + wbemFlagForwardOnly)
For Each objItem In colItems
GetCPUUsage = objItem.PercentProcessorTime
Next
End Function

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.