Error in HTA with fileopen - html

I'm using a script from Rob van der Woude for the open file dialog (top post from here) which is apparently supposed to work in HTA but I get an error saying:
"ActiveX component can't create object: 'UserAccounts.CommonDialog'"

This function may be helps you !
BrowseForFile.vbs
'**************************************************************************************
' GetFileDlg() And GetFileDlgBar() by omen999 - may 2014 - http://omen999.developpez.com
' Universal Browse for files function
' compatibility : all versions windows and IE - supports start folder, filters and title
' note : the global size of the parameters cannot exceed 191 chars for GetFileDlg and 227 chars for GetFileDlgBar
'**************************************************************************************
Function GetFileDlg(sIniDir,sFilter,sTitle)
GetFileDlg=CreateObject("WScript.Shell").Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg('" & sIniDir & "',null,'" & sFilter & "','" & sTitle & "')));close();}</script><hta:application showintaskbar=no />""").StdOut.ReadAll
End Function
Function GetFileDlgBar(sIniDir,sFilter,sTitle)
GetFileDlgBar=CreateObject("WScript.Shell").Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg('" & sIniDir & "',null,'" & sFilter & "','" & sTitle & "')));close();}</script>""").StdOut.ReadAll
End Function
' sample test
sIniDir = "C:\Windows\Fonts\*"
sFilter = "All files (*.*)|*.*|Microsoft Word (*.doc;*.docx)|*.doc;*.docx|Adobe pdf (*.pdf)|*.pdf|"
sTitle = "GetFileDlg by omen999 2014 - omen999.developpez.com"
' (sIniDir + sFilter + sTitle) size doesn't exceed 191 chars (227 for GetFileDlgBar)
' MsgBox Len(Replace(sIniDir,"\","\\")) + Len(sFilter) + Len(sTitle)
' sIniDir must be conformed to the javascript syntax
rep = GetFileDlg(Replace(sIniDir,"\","\\"),sFilter,sTitle)
MsgBox rep & vbcrlf & Len(rep)

As #JosefZ mentioned in the comments, the UserAccounts.CommonDialog library is available in Windows XP only. However, there are other ways to display an "Open File" dialog.
The Shell.Application object has a BrowserForFolder() function that, by default, displays a dialog asking you to select a folder. However, you can configure this dialog in a number of ways by using combinations of the ulFlags values. For example, if you include the BIF_BROWSEINCLUDEFILES flag, the dialog will also show files in addition to folders.
Here's a minimal example showing how you can have the BrowserForFolder dialog to display files and prompt the user to select a file:
' BROWSEINFO Flags...
Const BIF_NONEWFOLDERBUTTON = &H0200 ' Hide the [New Folder] button
Const BIF_BROWSEINCLUDEFILES = &H4000 ' Show files in addition to folders
' ShellSpecialFolderConstants...
Const ssfDESKTOP = 0
Dim objStartIn, objFile
With CreateObject("Shell.Application")
' Specify the folder the dialog should start in...
Set objStartIn = .NameSpace(ssfDESKTOP) ' Start in a special folder
Set objStartIn = .NameSpace("c:\") ' Or, start in custom path
' Args = (parent window, dialog title, flags, start folder)
Set objFile = .BrowseForFolder(0, "Select a file:", _
BIF_BROWSEINCLUDEFILES Or BIF_NONEWFOLDERBUTTON, objStartIn)
End With
If Not objFile Is Nothing Then
WScript.Echo objFile.Self.Path
End If
Of course, the user could still select a folder. There's no way to stop that from happening. But you can check the item returned to see if it's a folder and prompt them to reselect (perhaps in a loop).
If objFile.Self.IsFolder Then
' Invalid
End If

Related

How to run .vbs through .bat file to convert .xls to .csv

I am completely new to scripting, so please forgive my ignorance.
(Running Windows 10)
I found a working solution to convert .xls files to .csv using the .vbs from this post:
Convert xls to csv.
The files I'm working with have multiple sheets, and the vbs works by dragging the file(s) onto the vbs file icon to execute. I don't understand how the vbs gets the input arguments. I copied this code posted by Chris Rudd
'Courtesy of Chris Rudd on stackoverflow.com
'Modified by Christian Lemer
'plang
'ScottF
' https://stackoverflow.com/questions/1858195/convert-xls-to-csv-on-command-line
'* Usage: Drop .xl* files on me to export each sheet as CSV
'* Global Settings and Variables
'Dim gSkip
Set args = Wscript.Arguments
For Each sFilename In args
iErr = ExportExcelFileToCSV(sFilename)
' 0 for normal success
' 404 for file not found
' 10 for file skipped (or user abort if script returns 10)
Next
WScript.Quit(0)
Function ExportExcelFileToCSV(sFilename)
'* Settings
Dim oExcel, oFSO, oExcelFile
Set oExcel = CreateObject("Excel.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
iCSV_Format = 6
'* Set Up
sExtension = oFSO.GetExtensionName(sFilename)
if sExtension = "" then
ExportExcelFileToCSV = 404
Exit Function
end if
sTest = Mid(sExtension,1,2) '* first 2 letters of the extension, vb's missing a Like operator
if not (sTest = "xl") then
if (PromptForSkip(sFilename,oExcel)) then
ExportExcelFileToCSV = 10
Exit Function
end if
End If
sAbsoluteSource = oFSO.GetAbsolutePathName(sFilename)
sAbsoluteDestination = Replace(sAbsoluteSource,sExtension,"{sheet}.csv")
'* Do Work
Set oExcelFile = oExcel.Workbooks.Open(sAbsoluteSource)
For Each oSheet in oExcelFile.Sheets
sThisDestination = Replace(sAbsoluteDestination,"{sheet}",oSheet.Name)
oExcelFile.Sheets(oSheet.Name).Select
oExcelFile.SaveAs sThisDestination, iCSV_Format
Next
'* Take Down
oExcelFile.Close False
oExcel.Quit
ExportExcelFileToCSV = 0
Exit Function
End Function
Function PromptForSkip(sFilename,oExcel)
if not (VarType(gSkip) = vbEmpty) then
PromptForSkip = gSkip
Exit Function
end if
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sPrompt = vbCRLF & _
"A filename was received that doesn't appear to be an Excel Document." & vbCRLF & _
"Do you want to skip this and all other unrecognized files? (Will only prompt this once)" & vbCRLF & _
"" & vbCRLF & _
"Yes - Will skip all further files that don't have a .xl* extension" & vbCRLF & _
"No - Will pass the file to excel regardless of extension" & vbCRLF & _
"Cancel - Abort any further conversions and exit this script" & vbCRLF & _
"" & vbCRLF & _
"The unrecognized file was:" & vbCRLF & _
sFilename & vbCRLF & _
"" & vbCRLF & _
"The path returned by the system was:" & vbCRLF & _
oFSO.GetAbsolutePathName(sFilename) & vbCRLF
sTitle = "Unrecognized File Type Encountered"
sResponse = MsgBox (sPrompt,vbYesNoCancel,sTitle)
Select Case sResponse
Case vbYes
gSkip = True
Case vbNo
gSkip = False
Case vbCancel
oExcel.Quit
WScript.Quit(10) '* 10 Is the error code I use to indicate there was a user abort (1 because wasn't successful, + 0 because the user chose to exit)
End Select
PromptForSkip = gSkip
Exit Function
End Function
This works well for my needs, but I want to run it hourly and save the .csv files to a new directory.
I tried to run the .vbs using the Task Scheduler, but it only opens the file in my text editor, it doesn't execute. My thought was to create a .batch file that runs the .vbs. I thought I could call the .vbs with PowerShell commands like this:
Start "XlsToCsv"
Start "XlsToCsv.vbs"
But both of those have the same effect of opening the .vbs in the text editor.
Perhaps a simpler question is, "How do I run a .vbs file from the PowerShell or the Command Prompt?"
Any help would be greatly appreciated.
This method works consistently in the batch environment, however cannot use doublequotes as would be advisable for filepaths with spaces.
Start filepath\name.vbs
no Doublequotes.
This method works Consistently in cmd.exe console, however fails in .bat programs:
WSscript.exe "filepath\name.vbs"
Wscript/Window Script host provides an environment to execute scripts in a variety of languages and Cscript starts a script in command line environment.
So, If you want to run your script in console use cscript.exe and wscript.exe if you don't want the console window. So, as T3RR0R mentioned you need to use WScript command to run it.
Sometimes, executing a VBscript in windows opens text editor rather than running it. This is due to changes in the default file associations. Some time antivirus will also do this in order to protect your system. In that case, you need to change the registry check this link https://superuser.com/questions/1108349/change-default-program-for-opening-vbs-files
Take look in this file.gif:
I'm understood that this only works if you're using the file vbs by Drag and Drop passing as arguments...
You can see instructions left by author about how to use in the vbs in 7rd line:
Drop .xl* files on me to export each sheet as CSV
Obs.: .xl* is equal to "any file with (.xl)"+any" == *.xlsx, *.xlsm...
Take look in this file.gif that you can see how to pass arguments in vbs, (is the same to cmd & bat) files by Drag and Drop:
This file.png show how to use arguments with the
The code you have tried are not using/passing any arguments (parameters), without pass any arguments, (one or more files) this will always fail!
If you need try using some like:
"XlsToCsv.vbs" "one_file_dot.extensio_equal_xlsx_.xlsx" "one_more_another_file_dot.extensio_equal_xlsx_too.xlsx"
rem :: observing if you are try in a different folder where the vbs + xlsx file are, try this:
"d:\folder\where\vbs\are\XlsToCsv.vbs" "d:\folder\where\xlsx\file1\are\1file_dot.extension_equal_xlsx_.xlsx" "d:\folder\where\xlsx\file1\are\one\more\are\too\one_more_another_file_dot.extensio_equal_xlsx_too.xlsx"
__
This is who I have using your vbs files in same folder where the files **.xlsx* are, so, no need passing the drive\folder path:
wscript 58924333.vbs "012019.xlsx" "022019.xlsx"
rem :: or ::
cscript 58924333.vbs "012019.xlsx" "022019.xlsx"
So sorry my limited English

Access and File Picker

I want to fill a textbox with a file path so that I can then add the filepath as a hyperlink in a record.
I created a button and wrote this subroutine:
Private Sub Browsebutt_Click()
Dim fd As Object
Set fd = Application.FileDialog(3) 'msoFileDialogFilePicker
With fd
.Filters.Clear
.InitialFileName = CurrentProject.Path & "\"
.Title = "Select File"
.AllowMultiSelect = False
.ButtonName = "Select"
.Filters.Add "All Files (*.*)", "*.*"
'.InitialView = msoFileDialogViewList'
If .Show Then
Me.Offlink = .SelectedItems(1)
Else
Exit Sub
End If
End With
Everything looks fine but the issue is when I browse to something stored in my company NAS. The path looks like this:
Z:\Folder1\File
It doesn't work on click, if instead of this I use the drag and drop function directly into the access table (not in the form) I obtain something like this:
\192.168.0.155\archive\Folder1\File
and it actually works, when I click on the link it opens my file.
So I was wondering if there is a way to have the file picker to provide the path with full ip.
Answering this will require some steps, and might depend slightly on your setup:
You can't change the file picker behaviour a lot, so I'm going to change out the drive letter for the UNC path. Depending on how your drive is mapped, it will either return a server name (such as \\MyServer or \\www.AnUrl.tld), or an IP address
First, I'm going to use a couple of helper functions I found here and adapted to use late bindings and increase usability.
Helper 1: Input: a full path. Output: the drive letter from that path
Public Function ParseDriveLetter(ByVal path As String) As String
'Get drive letter from path
ParseDriveLetter = vbNullString
On Error GoTo err_ParseDriveLetter
Dim oFileSystem As Object ' Scripting.FileSystemObject
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Dim oFolder As Object 'Scripting.Folder
' Next line throws error if mapping not available
Set oFolder = oFileSystem.GetFolder(path)
If (oFolder Is Nothing) Then
Debug.Print "ParseDriveLetter: Folder '" & path & "' is invalid"
Else
ParseDriveLetter = oFileSystem.GetDriveName(oFolder.path)
End If
Set oFolder = Nothing
Set oFileSystem = Nothing
Exit Function
err_ParseDriveLetter:
Select Case Err.Number
Case 76:
' Path not found -- invalid drive letter or letter not mapped
Case Else
MsgBox "Error no. " & CStr(Err.Number) & ": " & Err.Description & vbNewLine & _
"Was caused by " & Err.Source, vbOKOnly Or vbExclamation, "Error in function ParseDriveLetter"
End Select
End Function
Helper 2: Input: a drive letter from a mapped network drive. Output: the location the drive is mapped to
Public Function GetMappedPathFromDrive(ByVal drive As String) As String
Dim oWshNetwork As Object 'New WshNetwork
Dim oDrives As Object 'New WshCollection
Set oWshNetwork = CreateObject("WScript.Network")
' The EnumNetworkDrives method returns a collection.
' This collection is an array that associates pairs of items ? network drive local names and their associated UNC names.
' Even-numbered items in the collection represent local names of logical drives.
' Odd-numbered items represent the associated UNC share names.
' The first item in the collection is at index zero (0)
Set oDrives = oWshNetwork.EnumNetworkDrives
Dim i As Integer
For i = 0 To oDrives.Count - 1 Step 2
' Drive is oDrives.Item(i), UNC is oDrives.Item(i + 1)
If (0 = StrComp(drive, oDrives.Item(i), vbTextCompare)) Then
' We have matched the drive letter. Copy the UNC path and finish
GetMappedPathFromDrive = oDrives.Item(i + 1)
Exit For
End If
Next
Set oDrives = Nothing
Set oWshNetwork = Nothing
End Function
And now, the implementation in your code:
Me.Offlink = Replace(.SelectedItems(1), ParseDriveLetter(.SelectedItems(1)), GetMappedPathFromDrive(ParseDriveLetter(.SelectedItems(1))))
Note that if this returns the server name instead of the IP address, you can use the post #June7 referred to to get the IP address.

Can I share an MS-Access database application via Dropbox?

I have a small Access application that only 3 or 4 people will ever use, but I want them to be able to use it from different locations. Only one person will use it at a time. They are a non-profit with little to no funding. They don't have a server and are currently sharing an Excel spreadsheet back and forth between all of them. The easiest thing I could think of doing was to upload the .accdb file to a Dropbox account and have them access it from there. I know that you can publish it to SharePoint, but all they have are local copies of Office. Are there any issues with doing the Dropbox thing or are there any better alternatives any of you could suggest?
I agree that using a Dropbox folder as a shared location could possibly work provided that only one person had the database open at any one time. If more than one person opened the database at the same time then when Dropbox went to sync the file it could clobber somebody else's changes, or have sync conflicts, or perhaps just get horribly confused.
If I was to try using this approach I certainly would not rely on telling users to "always check if somebody else is using the database before opening it" or "always open the database in Exclusive mode". Instead, I would use a little launcher script like the following VBScript to manage access to the database. It uses a second file extension (.Available or .IN_USE) to indicate the status of the database file, makes a local (not synced) copy, opens that copy in Access, and then copies the updated file back to the Dropbox folder so it can be synced.
Option Explicit
Dim WshShell, fso, f, AccessPath, DropboxFolder, WorkingFolder, DatabaseName
Const TemporaryFolder = 2
DropboxFolder = "C:\Users\Gord\Dropbox\dbStorage\"
DatabaseName = "myDatabase.accdb"
Set fso = CreateObject("Scripting.FileSystemObject")
WorkingFolder = fso.GetSpecialFolder(TemporaryFolder) & "\"
If fso.FileExists(DropboxFolder & DatabaseName & ".Available") Then
Set f = fso.GetFile(DropboxFolder & DatabaseName & ".Available")
f.Name = DatabaseName & ".IN_USE"
WScript.Echo "Copying database file to working folder..."
f.Copy WorkingFolder & DatabaseName
Set f = Nothing
Set WshShell = CreateObject("WScript.Shell")
AccessPath = WshShell.RegRead("HKEY_CLASSES_ROOT\Access.MDBFile\shell\Open\command\")
AccessPath = Left(AccessPath, InStr(AccessPath, "MSACCESS.EXE") + 12)
WScript.Echo "Launching Access..."
WshShell.Run AccessPath & " """ & WorkingFolder & DatabaseName & """", 1, True
WScript.Echo "Copying database file back to Dropbox folder..."
fso.CopyFile WorkingFolder & DatabaseName, DropboxFolder & DatabaseName & ".IN_USE"
Set f = fso.GetFile(DropboxFolder & DatabaseName & ".IN_USE")
f.Name = DatabaseName & ".Available"
Set f = Nothing
Else
If fso.FileExists(DropboxFolder & DatabaseName & ".IN_USE") Then
MsgBox "The database is currently in use. Try again later."
Else
MsgBox "The database could not be found."
End If
End If
Set fso = Nothing
The launcher could be invoked by a shortcut whose target is
CSCRIPT.EXE C:\wherever\launchMyDatabase.vbs
This is an enhanced version of Gord Thompsons script which tries to inform the user to help them do the "right thing".
It also deals with exceptional behaviour such as bad internet access (it encourages the user NOT to use it!) and it also deals with the script being terminated by the user once access has been opened)
' This uses a second file extension (.Available or .InUse) to indicate the status of the database file,
' makes a local (not synced) copy inthe temp folder and opens that copy in Access.
' The updated file is copied back to the Dropbox folder so it can be synced.
' A backup fodler and file can be created with a date in the filename if the suer chooses to.
'
' The launcher could be invoked by a shortcut whose target is
'
' CSCRIPT.EXE C:\!AA\OpenFMFtoolDatabase.vbs
' Or to debug (it can open in VS if VS has been setup right with an external tool)
' CSCRIPT.EXE /X C:\!AA\OpenFMFtoolDatabase.vbs
' ----------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------
' This file is used to open and backup the FMFtool university and Subject database
'
' It can be invoked by a shortcut whose target is CSCRIPT.EXE C:\!AA\OpenFMFtoolDatabase.vbs
'
' See the tag #DOTHESE below for constants that need to be changed for each specific user
'Option Explicit
' ----------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------
' Supporting functions
'
Function LPad(MyString, MakeStringThisLong, PadWithThisChar)
Dim n: n = 0
If MakeStringThisLong > Len(MyString) Then n = MakeStringThisLong - Len(MyString)
LPad = String(n, PadWithThisChar) & MyString
End Function
Function BuildDateForFile()
Dim TheMonth, TheDay
TheMonth = LPad(Month(Date), 2, "0")
TheDay = LPad(Day(Date), 2, "0")
BuildDateForFile = DatePart("yyyy", Now) & TheMonth & TheDay & "_"
End Function
' ----------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------
' Main Procedure
'
Sub OpenDatabase()
' -----------------------------------------------------------------
' -----------------------------------------------------------------
' USER / MACHINE SPECIFIC #DOTHESE
Const SupportEmail = "mr#harveyfrench.co.uk"
' This script may prompt the user to contact support using this email address.
Const DropboxFolder = "C:\!AA\DropBox\"
' A typical value is "C:\Users\Gord\Dropbox\dbStorage\" Note that it must END WITH a backslash
' It is set to the name of the LOCAL folder (ie a folder on the PC running this script) which is synced with dropbox
' (or any internet based file sharing system like Dropbox, Onedrive, GDrive, etc)
Const DatabaseCalled = "University and Subject Database"
' The name of the database file without the file extension (ie no .accdb)
Const DatabaseExtension = ".accdb"
' The file extension (eg .accdb)
' -----------------------------------------------------------------
' -----------------------------------------------------------------
' General constants
Const TemporaryFolder = 2
Const TAGForINUSE = ".InUse"
Const TAGForAVAILABLE = ".Available"
Const TAGForOldLocalFile = ".OldFile"
Dim WshShell, f, AccessPath, WorkingFolder, DatabaseName
Dim FileNameWhenInUse, FileNameWhenAvailable
Dim DropBoxInUse, DropBoxAvailable
Dim DropboxBackupFolder, DropboxBackupFileName, DropboxDONOTBackupFileName
Dim LocalFile, OldLocalFile
Dim blnOpenLocalFile
' -----------------------------------------------------------------
' Use these lines when delivering the code
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
' -----------------------------------------------------------------
' Use may use these lines when writing the code
'Dim fso As Scripting.FileSystemObject
'Set fso = New Scripting.FileSystemObject
' -----------------------------------------------------------------
' About files and folders
DatabaseName = DatabaseCalled & DatabaseExtension
FileNameWhenInUse = DatabaseName & TAGForINUSE
FileNameWhenAvailable = DatabaseName & TAGForAVAILABLE
DropBoxInUse = DropboxFolder & FileNameWhenInUse
DropBoxAvailable = DropboxFolder & FileNameWhenAvailable
DropboxBackupFolder = DropboxFolder & "Backups"
WorkingFolder = fso.GetSpecialFolder(TemporaryFolder) & "\"
' eg often: C:\Users\Harvey\AppData\Local\Temp\
LocalFile = WorkingFolder & DatabaseName
OldLocalFile = LocalFile & TAGForOldLocalFile
blnOpenLocalFile = False
' -----------------------------------------------------------------
' WARN User
'
If vbNo = MsgBox("This will open " & DatabaseName & vbCrLf & _
vbCrLf & _
"DO YOU HAVE ACCESS TO THE WEB?" & vbCrLf & _
vbCrLf & _
"Do not click YES unless you are sure you do as the web is needed to prevent other people from opening the above file while you have it open. " & vbCrLf & _
vbCrLf & _
"NOTE 1: It is OK to loose web access once the file is opened - but others will not be able to use it again until you have web access (and have closed the file)." & vbCrLf & _
vbCrLf & _
"NOTE 2: If you click YES and you do not have web accesss, either you or someone else WILL LOOSE ALL changes made to the file!)", vbYesNo) Then
Exit Sub
End If
' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------
'
' Main processing -
' The file is only opened if it is available (ie not in use by another person).
' It can also be opened if it is determined that the file was not copied back to the dropbox folder
' but was "accidentally" left in the temp folder
' When it is opened the file is renamed on dropbox to indicate it is unavailable
'
If fso.FileExists(DropBoxAvailable) Then
Set f = fso.GetFile(DropBoxAvailable)
' This renames the file on dropbox to be "InUse"
f.Name = FileNameWhenInUse
'
' Allow dropbox to upload the file ASAP (if possible, force dropbox to sync here )
'
WScript.Echo "Copying database file to temp folder..."
f.Copy LocalFile
Set f = Nothing
blnOpenLocalFile = True
Else
If fso.FileExists(DropBoxInUse) Then
If fso.FileExists(LocalFile) Then
MsgBox "The database was found locally and will be opened " & vbCrLf & _
vbCrLf & _
"(it had already been previoulsy opened by you, but not written back to the dropbox folder (perhaps a process crashed)."
blnOpenLocalFile = True
Else
MsgBox "The database is currently in use by someone else. Try again later."
blnOpenLocalFile = False
End If
Else
MsgBox "The database could not be found on dropbox " & vbCrLf & _
vbCrLf & _
"(Both " & TAGForINUSE & " and " & TAGForAVAILABLE & " versions are missing from dropbox!)."
If fso.FileExists(LocalFile) Then
MsgBox "A Copy of the file exists locally on your computer. " & vbCrLf & _
vbCrLf & _
"(The file will be opened and written back to dropbox as usual BUT - " & vbCrLf & _
"please email " & SupportEmail & " as this situation should not be arising!)."
blnOpenLocalFile = True
Else
If fso.FileExists(OldLocalFile) Then
MsgBox "A backup copy of the local file exists (know as the OldLocalFile)" & vbCrLf & _
vbCrLf & "Email support on " & SupportEmail & vbCrLf & _
"to find out what to do (as this is a really wierd situation)."
Else
MsgBox "A backup copy of the local file DOES NOT EXIST " & vbCrLf & _
vbCrLf & "Email support on " & SupportEmail & vbCrLf & _
"..but being honest you may be in a really bad pickle, but if you've been taking backups you'll be fine!"
End If
blnOpenLocalFile = False
End If
End If
End If
If blnOpenLocalFile Then
' ---------------------------------------------------------------------------------
' Take a daily backup
'
If Not fso.FolderExists(DropboxBackupFolder) Then
WScript.Echo "Creating backup folder."
fso.CreateFolder DropboxBackupFolder
End If
DropboxBackupFileName = DropboxBackupFolder & "\" & BuildDateForFile() & DatabaseName
DropboxDONOTBackupFileName = DropboxBackupFileName & ".NoBackup"
DropboxBackupFileName = DropboxBackupFileName & ".Backup"
If Not (fso.FileExists(DropboxBackupFileName)) And Not (fso.FileExists(DropboxDONOTBackupFileName)) Then
If vbYes = MsgBox("Do you want to take a daily backup? " & vbCrLf & _
vbCrLf & "(click YES if a lot of work has been done since the last backup was taken. " & vbCrLf & _
" If in doubt click YES)", vbYesNo) Then
WScript.Echo "Creating daily backup file."
fso.CopyFile LocalFile, DropboxBackupFileName
Else
' Create an empty text file to flag no backup is wanted that day
WScript.Echo "No daily backup file will be created."
fso.CreateTextFile (DropboxDONOTBackupFileName)
End If
End If
' ---------------------------------------------------------------------------------
' Open the file
'
Set WshShell = CreateObject("WScript.Shell")
AccessPath = WshShell.RegRead("HKEY_CLASSES_ROOT\Access.MDBFile\shell\Open\command\")
AccessPath = Left(AccessPath, InStr(AccessPath, "MSACCESS.EXE") + 12)
WScript.Echo "Launching Access and Opening temp database file: " & vbCrLf & LocalFile
WshShell.Run AccessPath & " """ & LocalFile & """", 1, True
WScript.Echo "Copying temp database file back to Dropbox folder..."
fso.CopyFile LocalFile, DropBoxInUse
Set f = fso.GetFile(DropBoxInUse)
f.Name = FileNameWhenAvailable
Set f = Nothing
' Make another copy of the file that was copied to the dropbox folder, then delete the original file
' (This might help stop a bad catastrophe!)
WScript.Echo "In Temp Folder: Copying temp database file to be .oldfile"
fso.CopyFile LocalFile, OldLocalFile
WScript.Echo "In Temp Folder: Deleting temp database file "
fso.DeleteFile LocalFile
End If
Set fso = Nothing
End Sub
' Do the work!
OpenDatabase
I know this is an old question, I do not think it is possible to do this safely. The issue is that LDB files, which are the files that manages the share of connections to the database can lose track of open state. This occurs when external files are joined to the primary database via JOIN/IN type constructs. When this occurs the Jet/ADO engine still has locks on files even if the application exits, as the file specified in the IN clauses is opened but not closed when the query completes. Then DropBox creates conflicted copies of files and data is lost.

Access: Shell cmd Open MDB

I have been using the following command to open another MDB Access file via VBA:
Shell "cmd /c " & Chr(34) & strNewFullPath & Chr(34), vbHide
strNewFullPath is the full path of the MDB file.
Works fine when using Access 2010, but doesn't run on Access 2003.
If I run the command in a XP DOS terminal it DOES run.
What other command can I use that should work on Access 2003 up and with the Access Runtime?
If you want want to use Access VBA to open a database in another Access application instance, you can do this:
Dim objApp As Access.Application
Set objApp = New Access.Application
objApp.UserControl = True
objApp.OpenCurrentDatabase "C:\Access\sample.mdb"
Set objApp = Nothing
Setting UserControl to True leaves the new application instance open after the procedure finishes.
If you want the new Access instance hidden, include:
objApp.Visible = False
I'm suggesting this approach because it also gives you a way to automate the new application instance through the objApp object variable. But, if you're not interested in automating the new instance, this approach will probably only be useful if you can't make any other method work.
Try using Windows Scripting Host Object Model (WSHOM):
Sub RunFile(filename As String)
Dim oShell As Object
Set oShell = GetShell
If Not oShell Is Nothing Then
oShell.Run filename
End If
End Sub
Function GetShell() As Object
On Error Resume Next
Set GetShell = CreateObject("WScript.Shell")
End Function
The Windows file association should allow both types of files to open in their native application.
Sample Usage:
RunFile strNewFullPath
Optional Arguments:
There are two optional arguments for the Run method. Please note that much of this is copied from MSDN:
intWindowStyle (integer)
A number from 0 to 10:
0 - Hides the window and activates another window.
1 - Activates and displays a window. If the window is minimized or maximized, the system
restores it to its original size and position. An application should
specify this flag when displaying the window for the first time.
2 - Activates the window and displays it as a minimized window.
3 - Activates the window and displays it as a maximized window.
4 - Displays a window in its most recent size and position. The active
window remains active.
5 - Activates the window and displays it in its current size and position.
6 - Minimizes the specified window and activates the next top-level window in the Z order.
7 - Displays the window as a minimized window. The active window remains active.
8 - Displays the window in its current state. The active window remains active.
9 - Activates and displays the window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when restoring a minimized window.
10 - Sets the show-state based on the state of the program that started the application.
I am not aware of the default value for this parameter. Note that some programs simply ignore whatever value you set (I couldn't tell you which ones).
bWaitOnReturn (boolean)
Set to False for asynchronous code. The Run method returns control to the calling program before completing. Default is False.
You can use the Win32 API to find the EXE name associated with the file type and prepend it to your shell command like this:
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Public Function GetExecutableForFile(strFileName As String) As String
Dim lngRetval As Long
Dim strExecName As String * 255
lngRetval = FindExecutable(strFileName, vbNullString, strExecName)
GetExecutableForFile = Left$(strExecName, InStr(strExecName, Chr$(0)) - 1)
End Function
Sub RunIt(strNewFullPath As String)
Dim exeName As String
exeName = GetExecutableForFile(strNewFullPath)
Shell exeName & " " & Chr(34) & strNewFullPath & Chr(34), vbNormalFocus
End Sub
The problem with your shell command is the cmd prompt don't always support using the file extension to start a program. In fact, you better off to use
Start "path to some file with .extension"
The above is quite much the same as clicking.
However, what you really want to do is launch the msacces.exe and SUPPLY the path name to the file for it to open. This is especially the case with a runtime install.
So your code should look like this:
Sub testjump()
' jumps to a mde file called "upgrade.mde"
' it exists in the same directly as the currently running program
Dim strShellProg As String
Dim strCurrentDir As String
Const q As String = """"
strCurrentDir = CurrentProject.path & "\"
' path to msaccess is required here
strShellProg = q & SysCmd(acSysCmdAccessDir) & "msaccess.exe" & q
strShellProg = strShellProg & " " & q & strCurrentDir & "RidesUpGrade.mdE" & q
If Shell(strShellProg, vbNormalFocus) > 0 Then
' code here for shell ok
Application.Quit
Else
' code here for shell not ok
MsgBox "Un able to run Rides upgrade", vbCritical, AppName
Application.Quit
End If
End Sub
So the above uses the full path name to msaccess.exe. It been tested on xp, vista, win7 etc, and it always worked for me.
And in the case of more than one version of Access, or that of using a runtime, you may not want to use the extension to launch the file. So this ensures that you are using the SAME version and same .exe that you are currently running. So the above code pulls the current msaccess.exe path you are using, not one based on file extension.
I use this function when working in Access 2003:
Public Function RunExternalMDB(MDBName As String, WG As String, UsrNm As String, Pwd As String)
Shell "MsAccess.exe " & """" & MDBName & """" & " /wrkgrp " & """" & WG & """" & " /user " & UsrNm & " /pwd " & Pwd
End Function
This does work in Runtime mode : )
Here is a slight revision I used to make it work with accdr, where it is required that there be a runtime switch used.
strShellProg = q & SysCmd(acSysCmdAccessDir) & "msaccess.exe" & q & " /runtime"
strShellProg = strShellProg & " " & q & strCurrentDir & "spfe.accdr" & q
If Shell(strShellProg, vbNormalFocus) > 0 Then
DoCmd.Hourglass False
' DoCmd.Quit
Application.Quit
Else
' code here for shell not ok
MsgBox "Unable to run upgrade", vbCritical, AppName
DoCmd.Hourglass False
Application.Quit
End If

generate PDF using VBA

I want to generate a PDF file using VBA, I found some tools but I am not sure if it supports to generate in a table format. Or is there another third party tool(free) to generate an access form in PDF format?
Depending on what you want to export and what VBA application you are using you have a few options.
If you are exporting an access report then this is good (and free!) http://www.lebans.com/reporttopdf.htm
For most other things you can use a PDF print driver and push anything you want to export to the “printer”. There are a number of free and commercial options here so google is your friend
Stephen Leban's PDF export library was great for it's era, but that was many years ago, and the library is now not supported at all, which you can see from a quick visit to his web site. Fortunately, you can now use the built-in PDF export capabilities of Access. Here's an example:
DoCmd.OutputTo acOutputReport, "SimpleReport", acFormatPDF, "C:\Users\Paul\Documents\PDFTest01.pdf", False
I believe this works in Access 2007 and up; it definitely works with Access 2013. Here's a link to an MSDN forum post with more information.
Install a PDF print driver and use it to print out your sheet. For example, I have PDFCreator installed.
ActiveSheet.PrintOut ActivePrinter:="PDFCreator"
Warning: PDFCreator is free, but versions 0.9.7 and later come bundled with "tormentware". I have the cleaner version 0.9.6. Of course you can also install some other PDF driver.
The best way for you to create a PDF in Access is to first make the report in access.
The reason being that when you generate the report in Access first, you will have full control on exactly how you want the report to look like in PDF.
Assuming you know how to create reports in Access the following code will help you convert that report into a PDF that then allows the users to save the PDF accordingly.
Dim strReportName = "RptYourReportName" ' first quote in the name of the report you already created in access
Docmd.OpenReport strReportName, acViewPreview 'tell access to open up the report
Reports(strReportName).Visible = False
If Reports(strReportName).HasData then
Call ConverReportToPDF(strReportName,,"Give_Generic_Name.PDF",True,False)
End if
DoCmd.Close acReport, strReportName
Below is the Function that will convert your report - simply copy this into the modules part of your VBA code.
Hope this helps!!
Public Function ConvertReportToPDF( _
Optional RptName As String = "", _
Optional SnapshotName As String = "", _
Optional OutputPDFName As String = "", _
Optional ShowSaveFileDialog As Boolean = False, _
Optional StartPDFViewer As Boolean = True, _
Optional CompressionLevel As Long = 0, _
Optional PasswordOpen As String = "", _
Optional PasswordOwner As String = "", _
Optional PasswordRestrictions As Long = 0, _
Optional PDFNoFontEmbedding As Long = 0, _
Optional PDFUnicodeFlags As Long = 0 _
) As Boolean
' RptName is the name of a report contained within this MDB
' SnapshotName is the name of an existing Snapshot file
' OutputPDFname is the name you select for the output PDF file
' ShowSaveFileDialog is a boolean param to specify whether or not to display
' the standard windows File Dialog window to select an exisiting Snapshot file
' CompressionLevel - not hooked up yet
' PasswordOwner - not hooked up yet
' PasswordOpen - not hooked up yet
' PasswordRestrictions - not hooked up yet
' PDFNoFontEmbedding - Do not Embed fonts in PDF. Set to 1 to stop the
' default process of embedding all fonts in the output PDF. If you are
' using ONLY - any of the standard Windows fonts
' using ONLY - any of the standard 14 Fonts natively supported by the PDF spec
'The 14 Standard Fonts
'All version of Adobe's Acrobat support 14 standard fonts. These fonts are always available
'independent whether they're embedded or not.
'Family name PostScript name Style
'Courier Courier fsNone
'Courier Courier-Bold fsBold
'Courier Courier-Oblique fsItalic
'Courier Courier-BoldOblique fsBold + fsItalic
'Helvetica Helvetica fsNone
'Helvetica Helvetica-Bold fsBold
'Helvetica Helvetica-Oblique fsItalic
'Helvetica Helvetica-BoldOblique fsBold + fsItalic
'Times Times-Roman fsNone
'Times Times-Bold fsBold
'Times Times-Italic fsItalic
'Times Times-BoldItalic fsBold + fsItalic
'Symbol Symbol fsNone, other styles are emulated only
'ZapfDingbats ZapfDingbats fsNone, other styles are emulated only
Dim blRet As Boolean
' Let's see if the DynaPDF.DLL is available.
blRet = LoadLib()
If blRet = False Then
' Cannot find DynaPDF.dll or StrStorage.dll file
Exit Function
End If
On Error GoTo ERR_CREATSNAP
Dim strPath As String
Dim strPathandFileName As String
Dim strEMFUncompressed As String
Dim sOutFile As String
Dim lngRet As Long
' Init our string buffer
strPath = Space(Pathlen)
'Save the ReportName to a local var
mReportName = RptName
' Let's kill any existing Temp SnapShot file
If Len(mUncompressedSnapFile & vbNullString) > 0 Then
Kill mUncompressedSnapFile
mUncompressedSnapFile = ""
End If
' If we have been passed the name of a Snapshot file then
' skip the Snapshot creation process below
If Len(SnapshotName & vbNullString) = 0 Then
' Make sure we were passed a ReportName
If Len(RptName & vbNullString) = 0 Then
' No valid parameters - FAIL AND EXIT!!
ConvertReportToPDF = ""
Exit Function
End If
' Get the Systems Temp path
' Returns Length of path(num characters in path)
lngRet = GetTempPath(Pathlen, strPath)
' Chop off NULLS and trailing "\"
strPath = Left(strPath, lngRet) & Chr(0)
' Now need a unique Filename
' locked from a previous aborted attemp.
' Needs more work!
strPathandFileName = GetUniqueFilename(strPath, "SNP" & Chr(0), "snp")
' Export the selected Report to SnapShot format
DoCmd.OutputTo acOutputReport, RptName, "SnapshotFormat(*.snp)", _
strPathandFileName
' Make sure the process has time to complete
DoEvents
Else
strPathandFileName = SnapshotName
End If
' Let's decompress into same filename but change type to ".tmp"
'strEMFUncompressed = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
'strEMFUncompressed = strEMFUncompressed & "tmp"
Dim sPath As String * 512
lngRet = GetTempPath(512, sPath)
strEMFUncompressed = GetUniqueFilename(sPath, "SNP", "tmp")
lngRet = SetupDecompressOrCopyFile(strPathandFileName, strEMFUncompressed, 0&)
If lngRet <> 0 Then
Err.Raise vbObjectError + 525, "ConvertReportToPDF.SetupDecompressOrCopyFile", _
"Sorry...cannot Decompress SnapShot File" & vbCrLf & _
"Please select a different Report to Export"
End If
' Set our uncompressed SnapShot file name var
mUncompressedSnapFile = strEMFUncompressed
' Remember to Cleanup our Temp SnapShot File if we were NOT passed the
' Snapshot file as the optional param
If Len(SnapshotName & vbNullString) = 0 Then
Kill strPathandFileName
End If
' Do we name output file the same as the input file name
' and simply change the file extension to .PDF or
' do we show the File Save Dialog
If ShowSaveFileDialog = False Then
' let's decompress into same filename but change type to ".tmp"
' But first let's see if we were passed an output PDF file name
If Len(OutputPDFName & vbNullString) = 0 Then
sOutFile = Mid(strPathandFileName, 1, Len(strPathandFileName) - 3)
sOutFile = sOutFile & "PDF"
Else
sOutFile = OutputPDFName
End If
Else
' Call File Save Dialog
sOutFile = fFileDialog(OutputPDFName)
If Len(sOutFile & vbNullString) = 0 Then
Exit Function
End If
End If
' Call our function in the StrStorage DLL
' Note the Compression and Password params are not hooked up yet.
blRet = ConvertUncompressedSnapshot(mUncompressedSnapFile, sOutFile, _
CompressionLevel, PasswordOpen, PasswordOwner, PasswordRestrictions, PDFNoFontEmbedding, PDFUnicodeFlags)
If blRet = False Then
Err.Raise vbObjectError + 526, "ConvertReportToPDF.ConvertUncompressedSnaphot", _
"Sorry...damaged SnapShot File" & vbCrLf & _
"Please select a different Report to Export"
End If
' Do we open new PDF in registered PDF viewer on this system?
If StartPDFViewer = True Then
ShellExecuteA Application.hWndAccessApp, "open", sOutFile, vbNullString, vbNullString, 1
End If
' Success
ConvertReportToPDF = True
EXIT_CREATESNAP:
' Let's kill any existing Temp SnapShot file
'If Len(mUncompressedSnapFile & vbNullString) > 0 Then
On Error Resume Next
Kill mUncompressedSnapFile
mUncompressedSnapFile = ""
'End If
' If we aready loaded then free the library
If hLibStrStorage <> 0 Then
hLibStrStorage = FreeLibrary(hLibStrStorage)
End If
If hLibDynaPDF <> 0 Then
hLibDynaPDF = FreeLibrary(hLibDynaPDF)
End If
Exit Function
ERR_CREATSNAP:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
mUncompressedSnapFile = ""
ConvertReportToPDF = False
Resume EXIT_CREATESNAP
End Function