I've started to run into some concurrency issues with my databases. I have roughly ten different aacdb files in a shared location on our office network. One of these databases is kind of the 'master' database. It is split into backend and front end. The backend of this databases holds common tables such as users/passwords, employees, departments, etc etc.
Yesterday, I made two databases purely for input. They each have a single form bound to a table in 'data entry' mode, with record locks set to 'edited record.' They also link to some of the same tables shared by other databases. This is where I started to run into (likely?) concurrency issues for the first time.
People have been reporting odd behavior (forms not opening, etc) in the 'master' database. This was tested a bit and only happens when users are also in the linked data-entry only databases.
There are still less than ten current users across all of the databases at a given time.
Would drop down selections hold a lock on a table, preventing certain forms from opening?
AFAIK, dropdowns are just queried when the form is loaded.
Any ideas?
I had fits with this issue, trying to have several users share the same front end from a network share. Things would just...not work. Then when I went back it was impossible to dupilcate the failures. I decided to have the application installed on the local machines, but this had version control issues, especially since I had several different front ends running at the same time for different projects. There were updaters out there but they either cost money or I couldnt see the code and didnt trust them. I came up with this as a solution and have been using it since Access 2003.
This is a seperate ACCESS database, you have to lock it down just like you would any front end.
This launcher works for the four access front ends that I am running right now. There are two table that you have to setup on the network.
TABLE NAME: RunTimeTracking
FIELD: RTTID : AutoNumber
FIELD: RTTComputerName : Text
FIELD: RTTLoginTime : Date/Time
TABLE NAME: VersionControlTable
FIELD: VCTID : AutoNumber
FIELD: VCTVersion : Number
FIELD: VCTSourceLoc : Text
FIELD: VCTDest : Text
FIELD: VCTDateVer : Date/Time
The RunTimeTracking table works to prevent the user from starting the actual application without using the launcher. When the launcher runs it inserts a entry into the table with the computer name. When the application runs it looks for that entry, if it doesnt see it. It warns and dumps.
In the version control table put the location of the most up to date app, the location on the local machine where you want the applicaiton to be stored.
If you have more than one program that you are controlling, then increment VCTVersion entry and reference it in your code in the launcher.
strSQL = "SELECT * FROM VersionControlTable WHERE VCTVersion = 200"
When the launcher runs it checks the CREATED datestamp on the local file to the one on the network, if they are different, it copies. If not, it runs.
Private Sub Form_Load()
DoCmd.ShowToolbar "Ribbon", acToolbarNo
DoCmd.ShowToolbar "Status Bar", acToolbarNo
DoCmd.Maximize
Form.TimerInterval = 2000
End Sub
Private Sub Form_Timer()
runDataCheck
End Sub
Private Sub runDataCheck()
' This is the launcher program. This program is designed to check for
' Version information and upload and download the new version automaticaly.
' Place entry into the Run Time Tracking Table. This will be used by the Main Application to verify that
' The application was launched by the Launcher and not run straight from the desktop
'First, retrieve the name of the computer from the Environment.
Dim strCompName As String
strCompName = Environ("computername")
' Now, delete all entries on the tracking table that have this computer name associated with it.
' Later we will try to add a trigger that archives the logins.
Dim strSQL As String
strSQL = "DELETE FROM RunTimeTracking WHERE RTTComputerName = '" & strCompName & "'"
adoSQLexec (strSQL)
' Now, add and entry into the table
strSQL = "INSERT INTO RunTimeTracking (RTTComputerName,RTTLoginTime) VALUES ('" & strCompName & "','" & Now() & "')"
adoSQLexec (strSQL)
' First, retrieve the parameters from the Version Control File and put them into variables that we can use.
Dim strSource As String
Dim strDest As String
Dim dateVer As Date
Dim rs As New ADODB.Recordset
'LBLSplashLabel.Caption = "Checking Version Information...."
strSQL = "SELECT * FROM VersionControlTable WHERE VCTVersion = 200"
With rs
rs.Open strSQL, CurrentProject.Connection
End With
strSource = rs.Fields("VCTSourceLoc").Value
strDest = rs.Fields("VCTDest").Value
dateVer = rs.Fields("VCTDateVer").Value
Set rs = Nothing
' Next. See if the folders on both the local drive and the source drive exists.
Dim binLocal As Boolean
Dim binNet As Boolean
Dim binDirectoryLocal As Boolean
'Debug.Print strSource
' First check to see if the network file exists.
binNet = FileExists(strSource)
If binNet = False Then
MsgBox ("The network source files are missing. Please contact Maintenance!")
Application.Quit (acQuitSaveNone)
End If
' Get the timestamp from the network version since it exists.
Dim fileNet As File
Dim fileLocal As File
Dim fileNetObject As New FileSystemObject
Set fileNet = fileNetObject.GetFile(strSource)
Debug.Print strSource
Debug.Print "Created Date : " & fileNet.DateCreated
Dim strDirName As String
Dim intFind As Integer
' Check to see if the Local file Exists.
binLocal = FileExists(strDest)
If binLocal = False Then
'There is no local file. Check to see if the directory exists
' Get the directory name
intFind = (InStrRev(strDest, "\", , vbTextCompare))
strDirName = (Left(strDest, intFind - 1))
Debug.Print "Directory Name: " & strDirName
binDirectoryLocal = FolderExists(strDirName)
If binDirectoryLocal = False Then
'There is no local directory. Create one
MkDir (strDirName)
' LBLSplashLabel.Caption = "Copying Files...."
'Copy the source file to the directory.
FileCopy strSource, strDest
'Since we have no copied the latest version over, no need to continue. Open the main app
OpenMaintApp (strDest)
Else
' No need to create the directory, simply copy the file.
'Copy the source file to the directory.
' LBLSplashLabel.Caption = "Copying Files...."
FileCopy strSource, strDest
'Since we have no copied the latest version over, no need to continue. Open the main app
OpenMaintApp (strDest)
End If
End If
'Now we know that the file is in the directory, now we need to check its version.
'Get the last modified date from the file.
Set fileLocal = fileNetObject.GetFile(strDest)
Debug.Print "Last Modified Date : " & fileLocal.DateCreated
'Do the version check
If fileLocal.DateCreated <> fileNet.DateCreated Then
' LBLSplashLabel.Caption = "Copying Files...."
'Copy the source file to the directory.
FileCopy strSource, strDest
'Since we have no copied the latest version over, no need to continue. Open the main app
OpenMaintApp (strDest)
Else
OpenMaintApp (strDest)
End If
OpenMaintApp (strDest)
End Sub
Private Sub OpenMaintApp(strAppName As String)
Dim accapp As Access.Application
Set accapp = New Access.Application
accapp.OpenCurrentDatabase (strAppName)
accapp.Visible = True
DoCmd.Quit acQuitSaveNone
End Sub
Related
What I'm trying to do is pretty simple:
Iterate through all of the .accdb files in a directory
Open them and export all the tables to separate .xlsx files
The issue I'm running into is the scope of DoCmd and I'm having difficulty changing it. The issue is coming up because I'm running the VBA from what is basically and empty Database1.accdb. When the VBA gets to DoCmd.TransferSpreadsheet, it is using CurrentDb and not the Access file that was opened with OpenDatabase. It is saying a table that is clearly does see (Debug.Print(tbl.Name) works) doesn't exist.
See below:
Option Compare Database
Public Const PROJECT_PATH = "\\192.168.1.2\Migration\"
Public Const DESC_PATH = PROJECT_PATH & "Descriptions\"
Public Const DESC_DB_PATH = DESC_PATH & "DBs\"
Public Const DESC_EXPORTS = DESC_PATH & "Exports\"
Sub ExportDescriptionTables()
Dim wrkSpace As Workspace, _
db As Database, _
tbl As TableDef
' ************************** TEMPLATE FILES - BEGIN *************************
Set dbDirObj = CreateObject("Scripting.FileSystemObject")
Set dbFolder = dbDirObj.GetFolder(DESC_DB_PATH)
Set dbFiles = dbFolder.Files
' ************************** TEMPLATE FILES - END ***************************
' Create the Access object for this file
Set wrkSpace = CreateWorkspace("", "admin", "", dbUseJet)
' Iterate through each Access file
For Each dbFile In dbFiles
' Open each Access database file
Set db = wrkSpace.OpenDatabase(DESC_DB_PATH & dbFile.Name)
' Iterate through each table
For Each tbl In db.TableDefs
' Export based on the table name matching specific criteria
If Left(tbl.Name, 1) <> "~" And Left(tbl.Name, 4) <> "MSys" Then
Debug.Print (tbl.Name)
' ################### THIS WHERE THE ERROR OCCURES ##############
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, tbl.Name, DESC_EXPORTS & tbl.Name & dbFile.Name, True, tbl.Name
End If
Next tbl
' Close database
db.Close
' Clear out access object for this file
Set db = Nothing
Next dbFile
End Sub
So my questions:
Is there a way I'm simply not seeing for setting the scope of DoCmd?
If not, what would be a better approach to this (perhaps running from Excel potentially forcing the CurrentDb to be the only open Acccess DB, which should bring DoCmd into proper scope)?
No. Always think of DoCmd as something a user can do via the user interface.
When located a database and the table(s) within this to export, link this/these to the main database (with DoCmd.TransferDatabase), then export each linked table and delete it afterwards.
DoCmd is a child of an Application object. You can create a new Access application session and open your target database there. Then when you call DoCmd.TransferSpreadsheet within that session, it will look within its "own" database for the names of the tables (or queries) you ask it to export.
Here's a simple example, which exports just one table from one database.
Dim objAccess As Object
Set objAccess = CreateObject("Access.Application")
'objAccess.Visible = True ' useful during development and for trouble-shooting
objAccess.OpenCurrentDatabase "C:\Temp\Northwind_2007.accdb"
objAccess.DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
"Customers", "C:\Temp\Customers.xlsx"
objAccess.CloseCurrentDatabase
objAccess.Quit
There are three separate shared Access databases (tampa1, tampa2, tampa3), multiple users access them. Each user needs to be able to switch databases (using a dropdown list/combo) at any given time, when the user does so. Goal: the program should be able to open the new database in the same instance and close the exiting database (in either order) if it was opened by the same user. I don't want the database to close another instance of any of the three databases opened by different user.
I was able to create the first part of the code, opening the database (although I am not sure if it has been opened in same or different instance). I created a code to close the exiting db (Applicaton.quit), however when I run the code, both databases are closed.
Public Sub Opendb21()
Static acc As Access.Application
Dim db As DAO.Database
Dim strDbName As String
Set acc = New Access.Application
strDbName = "C:\Users\YOURNAME\Documents\Opening multiple db Test\tampa2.accdb"
Set db = acc.DBEngine.OpenDatabase(strDbName, False, False)
acc.OpenCurrentDatabase strDbName
acc.Visible = True
'db.Close
'Set dbRemote = acc.CurrentDb
Set db = Nothing
'Closing the current db tampa1
Forms!Form1.cmd_CloseAccess_Click
End Sub
'Second sub
'Closing cmd -macro converted to VBA code
'This is on Form1, tampa1 database
Public Sub cmd_CloseAccess_Click()
DoCmd.Quit acQuitSaveAll
End Sub
I am expecting the program to close the current db (tampa1); open the second db (tampa2), but the program closes both instead. I need a way to make sure the code doesn't close an instance currently open by different user.
thank you for your hints! I found the solution to the issue by reading another Stack overflow posting, here is the link to that posting:
Access: Shell cmd Open MDB
I was missing the command "Application.UserControl=True" , which makes the application persistent and visible. I created a form which has a combo box that lists the databases I want to switch to. The variable ("OpenWhat")captures the name of the specific database and passes the parameter to a Module Sub, where it then completes the string by adding the rest of the information. After the new database is open, the Form in the first database closes the calling database.
Here is my particular piece of code:
Private Sub cbb_open_otherdb_AfterUpdate()
Dim OpenWhat As String
OpenWhat = Forms!Form1.cbb_open_otherdb.Value
Call Opendb(OpenWhat)
Forms!Form1.cmd_CloseAccess_Click
End Sub
Public Sub cmd_CloseAccess_Click()
On Error GoTo cmd_CloseAccess_Click_Err
DoCmd.Quit acQuitSaveAll
cmd_CloseAccess_Click_Exit:
Exit Sub
cmd_CloseAccess_Click_Err:
MsgBox Error$
Resume cmd_CloseAccess_Click_Exit
End Sub
Option Compare Database
Option Explicit
Public Sub Opendb(ByVal OpenWhat)
Dim objApp As Access.Application
Set objApp = New Access.Application
objApp.UserControl = True
objApp.OpenCurrentDatabase "C:\Users\YOURNAME\Documents\Opening multiple db Test\" + OpenWhat & ".accdb"
MsgBox ("Opening ") & OpenWhat
Debug.Print OpenWhat
Set objApp = Nothing
End Sub
I copied similar code to the other two databases to create a navigation ring.
Thank you for your help!
This is a follow up to this question and great answer:
Copy files with progress bar
So I added the code from Siddharth Rout's answer and it does exactly what I want to happen with a minor exception. When I copy the files, I am looping through each file in the directory and copying it up as long as it is not *List.xml. Because I am replacing an existing library the 97% of the documents are pre-existing and I get prompted to replace existing documents each time.
Is there a way to get it to prompt me to choose to replace for all files? Do I need to reformat/structure the sequence of my code?
Function UploadToSharepoint(Folderpath As String, Foldername As String, Filenames() As String, SharepointLinks() As String) As Boolean
'upload file to sharepoint library based on the folder name
Dim SharePointLib As String
Dim LocalAddress As String
Dim DestinationAddress As String
Dim xCounter As Long
On Error GoTo loadFailed
Pickafolder:
Folderpath = FolderPick
Foldername = Left(Folderpath, Len(Folderpath) - 1)
Foldername = RIght(Foldername, Len(Foldername) - InStrRev(Foldername, "\"))
Select Case Foldername
Case "OPSS", "SSP", "OPSD", "MTOD", "SSD"
SharePointLib = "\\my.company.com\Subsite\" & Foldername & "\"
Case "West", "Eastern", "Northeastern", "Northwestern", "Head Office"
SharePointLib = "\\my.company.com\Subsite\NSP\" & Foldername & "\"
Case "NSP", "NSSP"
MsgBox "Pick the NSP regional sub folder: West, Eastern, Northeastern, Northwestern, Head Office"
GoTo Pickafolder
Case Else
MsgBox "Inappropriate directory to upload from. Please select one of the CPS download directories"
GoTo Pickafolder
End Select
Filenames = GetFilesDir(Folderpath)
ReDim SharepointLinks(LBound(Filenames) To UBound(Filenames))
For xCounter = LBound(Filenames) To UBound(Filenames)
LocalAddress = Folderpath & Filenames(xCounter)
DestinationAddress = SharePointLib & Filenames(xCounter)
'**********************************************************
Call VBCopyFolder(LocalAddress, DestinationAddress)
'**********************************************************
SharepointLinks(xCounter) = "#http:" & Replace(DestinationAddress, "\", "/") & "#"
Next xCounter
UploadToSharepoint = True
Exit Function
loadFailed:
UploadToSharepoint = False
End Function
And by the looks of things I am not excluding the file I was referring to earlier...must be doing that else where.
Update
Based on comment received at the linked question, the solution is to declare a public constant at the start:
Public Const FOF_NOCONFIRMATION As Long = &H10
and then in the copy procedure change the line of code to:
.fFlags = FOF_SIMPLEPROGRESS Or FOF_NOCONFIRMATION
Now, this does solve the problem of being constantly asked to confirm the replacement. I am very happy about this. The problem now is the progress window displays for the first file to be copied then disappears but fails to reappear for subsequent files. The remaining files still get copied and the prg carries on like it's supposed to. The whole point of the progress bar though was to let people know that "THINGS" were still happening in the background and now that is not happening. Is there something I need to adjust?
Update 2
After running my code and choosing a source directory on the network drive instead of the local computer, the copy window is popping up for every single file like I was expecting. I notice that sometimes the progress bar closes before reaching 100%. This leads me to believe that since the file sizes are so small that when it is copying from my local drive to sharepoint, the operation completes so fast that it does not have time to draw and update the progress window before its time to close it.
I am open to completely changing this code. The link to the original is in the code itself. I'm sure there's an easier way to do it and the actual renaming part is NOT my own code, so I will redo it so it isn't plagiarizing. I can't use a batch file renamer to do it; I need to make it myself to stay out of trouble with legal :) No grey area!
Anyways, after a few dozen attempts on my own, I finally caved and grabbed this code online that is supposed to rename the files I specify. I edited it to fit my parameters and assigned variables/directories. When I run it, however, I always get a return of zero and the files are not being renamed. The one thing I could think of is that this directory is going to the full path name of the folder instead of the part after the last "\". But I'm not sure how to fix this either. I thought about trying to tell it to only tell it to pull, say the last 8 characters of the string, but that won't work either as these string lengths will vary anywhere from one character to 20 or so characters.
Here is my code:
Private Sub Apply_Click()
'This will initiate Module 1 to do a batch rename to find and replace all
'Module 1 will then initiate the resolving links process
Dim intResponse As Integer 'Alerts user to wait until renaming is complete
intResponse = MsgBox("Your folders are being updated. Please wait while your files are renamed and your links are resolved.")
If intResponse = vbOK Then 'Tests to see if msgbox_click can start a new process
Dim i As Integer
Dim from_str As String
Dim to_str As String
Dim dir_path As String
from_str = Old_Name_Display.Text
to_str = New_Name.Text
dir_path = New_Name.Text
If Right$(dir_path, 1) <> "\" Then dir_path = dir_path _
& "\"
Old_Name_Display = dir$(dir_path & "*.*", vbNormal)
Do While Len(Old_Name_Display) > 0
' Rename this file.
New_Name = Replace$(Old_Name_Display, from_str, to_str)
If New_Name <> Old_Name_Display Then
Name Old_Name_Display.Text As New_Name.Text
i = i + 1
End If
' Get the next file.
Old_Name_Display = dir$()
Loop
MsgBox "Renamed " & Format$(i) & " files. Resolving links now."
If intResponse = vbOK Then
MsgBox "You selected okay. Good luck coding THIS." 'Filler line to test that next step will be ready to initialize
Else: End
End If
Exit Sub
'Most of batch renaming process used from VB Helper, sponsored by Rocky Mountain Computer Consulting, Inc. Copyright 1997-2010; original code available at http://www.vb-helper.com/howto_rename_files.html
End Sub
Does anyone have another theory on why I get a 0 return/how to fix that potential above problem?
It doesn't look like the directory is getting referenced in the rename.
Change
Name Old_Name_Display.Text As New_Name.Text
to
Name Dir_Path & Old_Name_Display.Text As Dir_Path & New_Name.Text
I'm writing an Excel file recovery program with VB.Net that tries to be a convenient place to gather and access Microsoft's recommended methods. If your interested in my probably kludgy, error filled, and lacking enough cleanup code it's here: http://pastebin.com/v4GgDteY. The basic functionality seems to work although I haven't tested graph macro table recovery yet.
It occurred to me that Vista and Windows 7 users could benefit from being offered a list of previous versions of the file within my application if the Shadow Copy Service is on and there are previous copies. How do I do this?
I looked at a lot of web pages but found no easy to crib code. One possibility I guess would be to use vssadmin via the shell but that is pretty cumbersome. I just want to display a dialogue box like the Previous Versions property sheet and allow users to pick one of the previous versions. I guess I could just display the previous version property sheet via the shell by programmatically invoking the context menu and the "Restore previous versions choice", however I also want to be able to offer the list for Vista Home Basic and Premium Users who don't have access to that tab even though apparently the previous versions still exist. Additionally if it possible I would like to offer XP users the same functionality although I'm pretty sure with XP only the System files are in the shadow copies.
I looked at MSDN on the Shadow Copy Service and went through all the pages, I also looked at AlphaVSS and AlphaFS and all the comments. I'm kind of guessing that I need to use AlphaVss and AlphFS and do the following?
Find out the list of snapshots/restore points that exist on the computer.
Mount those snapshots.
Navigate in the mounted volumes to the Excel file the user wants to recover and make a list of those paths.
With the list of paths handy, compare with some kind of diff program, the shadow copies of the files with the original.
Pull out the youngest or oldest version (I don't think it matters) of those shadow copies that differ from the recovery target.
List those versions of the files that are found to be different.
This seems cumbersome and slow, but maybe is the fastest way to do things. I just need some confirmation that is the way to go now.
I finally decided to go ahead and start coding. Please make suggestions for speeding up the code or what do with files that are found to be different from the recovery file target. Is there a simpler way to do this with AlphaVSS and AlphaFS?
Private Sub Button1_Click_2(sender As System.Object, e As System.EventArgs) Handles Button1.Click
'Find out the number of vss shadow snapshots (restore
'points). All shadows apparently have a linkable path
'\\?\GLOBALROOT\Device\HarddiskVolumeShadowCopy#,
'where # is a simple one, two or three digit integer.
Dim objProcess As New Process()
objProcess.StartInfo.UseShellExecute = False
objProcess.StartInfo.RedirectStandardOutput = True
objProcess.StartInfo.CreateNoWindow = True
objProcess.StartInfo.RedirectStandardError = True
objProcess.StartInfo.FileName() = "vssadmin"
objProcess.StartInfo.Arguments() = "List Shadows"
objProcess.Start()
Dim burp As String = objProcess.StandardOutput.ReadToEnd
Dim strError As String = objProcess.StandardError.ReadToEnd()
objProcess.WaitForExit()
Dim xnum As Integer = 0
Dim counterVariable As Integer = 1
' Call Regex.Matches method.
Dim matches As MatchCollection = Regex.Matches(burp, _
"HarddiskVolumeShadowCopy")
' Loop over matches.
For Each m As Match In matches
xnum = xnum + 1
'At the max xnum + 1 is the number of shadows that exist
Next
objProcess.Close()
Do
'Here we make symbolic links to all the shadows, one at a time
'and loop through until all shadows are exposed as folders in C:\.
Dim myProcess As New Process()
myProcess.StartInfo.FileName = "cmd.exe"
myProcess.StartInfo.UseShellExecute = False
myProcess.StartInfo.RedirectStandardInput = True
myProcess.StartInfo.RedirectStandardOutput = True
myProcess.StartInfo.CreateNoWindow = True
myProcess.Start()
Dim myStreamWriter As StreamWriter = myProcess.StandardInput
myStreamWriter.WriteLine("mklink /d C:\shadow" & counterVariable _
& " \\?\GLOBALROOT\Device\HarddiskVolumeShadowCopy" _
& counterVariable & "\")
myStreamWriter.Close()
myProcess.WaitForExit()
myProcess.Close()
' Here I compare our recovery target file against the shadow copies
Dim sFile As String = PathTb.Text
Dim sFileShadowPath As String = "C:\shadow" & _
counterVariable & DelFromLeft("C:", sFile)
Dim jingle As New Process()
jingle.StartInfo.FileName = "cmd.exe"
jingle.StartInfo.UseShellExecute = False
jingle.StartInfo.RedirectStandardInput = True
jingle.StartInfo.RedirectStandardOutput = True
jingle.StartInfo.CreateNoWindow = True
jingle.Start()
Dim jingleWriter As StreamWriter = jingle.StandardInput
jingleWriter.WriteLine("fc """ & sFile & """ """ _
& sFileShadowPath & """")
jingleWriter.Close()
jingle.WaitForExit()
Dim jingleReader As StreamReader = jingle.StandardOutput
Dim JingleCompOut As String = jingleReader.ReadToEnd
jingleReader.Close()
jingle.WaitForExit()
jingle.Close()
Dim jingleBoolean As Boolean = JingleCompOut.Contains( _
"no differences encountered").ToString
If jingleBoolean = "True" Then
MsgBox(jingleBoolean)
Else
'I haven't decided what to do with the paths of
'files that are different from the recovery target.
MsgBox("No")
End If
counterVariable = counterVariable + 1
Loop Until counterVariable = xnum + 1
End Sub