I have some code, which works perfectly fine, that compacts an Access database when the database is opened.
However, I'm a little stuck as to how to do the next bit.
What I want to happen is that when an item within the DB table gets marked for archive and subsequently archived, I want this code to run almost like an AutoExec.
Could you please suggest the best way of doing this?
Thanks in advance
Option Compare Database
Private Sub Form_Timer()
'==================================================================
'The Timer event runs this code every minute. It compares your
'system time with the StartTime variable. When they match, it
'starts to compact all databases in the DBNames table.
'==================================================================
Dim StartTime As String
' Set this variable for the time you want compacting to start.
StartTime = Now()
' If StartTime is now, open the DBNames table and start compacting
If Format(Now(), "medium time") = Format(StartTime, _
"medium time") Then
Dim RS As Recordset, DB As Database
Dim NewDBName As String, DBName As String
Set DB = CurrentDb()
Set RS = DB.OpenRecordset("DBNames")
On Error Resume Next
RS.MoveFirst
Do Until RS.EOF
DBName = RS("DBFolder") & "\" & RS("DBName")
' Create a new name for the compacted database.
' This example uses the old name plus the current date.
NewDBName = Left(DBName, Len(DBName) - 4)
NewDBName = NewDBName & " " & Format(Date, "DDMMYY") & ".mdb"
DBEngine.CompactDatabase DBName, NewDBName
RS.MoveNext
Loop
' Close the form, and then close Microsoft Access
DoCmd.Close acForm, "CompactDB", acSaveYes
RS.Close
DoCmd.Quit acSaveYes
End If
End Sub
Related
So I have this Access form where I use this VBA code with a DAO connection to a MySQL database. Everything works great but if the user closes the form without clicking save button the new record is saved anyway.
So what I'm looking for is if there's any way the on the on close event I can stop the new record being saved to the database?
The code I have,
Private Sub Form_Load()
'Set Form Recordset
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim SQL As String
Set db = OpenDatabase("", False, False, Globales.ConnString)
SQL = "SELECT tbl6Suplidores.ID, tbl6Suplidores.NombreSuplidor, tbl6Suplidores.NumeroComerciante, tbl6Suplidores.DescripcionBienes, tbl6Suplidores.NombreContacto, tbl6Suplidores.NumeroTelefono, tbl6Suplidores.Email " _
& "FROM tbl6Suplidores;"
Set rs = db.OpenRecordset(SQL, dbOpenDynaset, dbAppendOnly)
Set Me.Form.Recordset = rs
End Sub
I'm thinking that since I used the dbAppendOnly it won't let me just delete current record on close event?
Any ideas welcome!
Thanks!
Consider a different approach where you have users enter an unbound form and click a save button to update the MySQL table from populated fields. Exiting form without save will do nothing. This is also a more proactive approach as it allows you to check validation and other logic prior to running save action.
Below uses a parameterized append query with QueryDefs. Also, ID is assumed to be an autonumber and hence left out of query. Sub should be placed behind the OnClick trigger event of save button.
Private Sub SaveButton_Click()
Dim db As DAO.Database, qdef As DAO.QueryDef
Dim SQL As String
Set db = OpenDatabase("", False, False, Globales.ConnString)
' PREPARED STATEMENT WITH NAMED PARAMETERS
SQL = "PARAMETERS ns_param VARCHAR(255), ncom_param INTEGER, db_param VARCHAR(255), " _
& " ncnt_param INTEGER, nt_param INTEGER, e_param VARCHAR(255);" _
& " INSERT INTO (NombreSuplidor, NumeroComerciante, DescripcionBienes, " _
& " NombreContacto, NumeroTelefono, Email) " _
& " VALUES (ns_param, ncom_param, db_param, ncnt_param, nt_param, e_param);"
' INITIALIZE QUERYDEF
Set qdef = db.CreateQueryDef("", SQL)
' BIND PARAMETERS TO FORM FIELDS
qdef!ns_param = Forms!MyFormName!NombreSuplidor
qdef!ncom_param = Forms!MyFormName!NumeroComerciante
qdef!db_param = Forms!MyFormName!DescripcionBienes
qdef!ncnt_param = Forms!MyFormName!NombreContacto
qdef!nt_biens_param = Forms!MyFormName!NumeroTelefono
qdef!e_param = Forms!MyFormName!Email
' RUN ACTION QUERY
qdef.Execute dbFailOnError
Set qdef = Nothing
End Sub
I have an access db that pulls volumes from a table of exceptions. Each volume has an ID. I've created queries to pull details, for all possible volumes, and saved each one with the same name as each volume ID. Each time the volume exceptions are pulled into this db, the volume IDs can change. So, there is a query that runs that updates the volume table with the new IDs.
Unless you know a way to do this with a query, I need to write Access VBA code that will loop through the volume table, identify the name of each query and then run those queries until it reaches the end of the table. For example, the code needs to look at the first record in the volume table, say it is 1040. This is the name of the query that needs to run. The code then needs to find the query named 1040 and run it. It is a make table query.
The table name is FacilityVolume and it has one field named Volume. The value in the field is shorttext format even though it is numeric.
I've tried a couple of different things. Here is my latest try.
Dim db as Database
Dim vol as Recordset
Dim code as QueryDef
Set db = CurrentDb()
Set vol = db.OpenRecordset("FacilityVolume")
Set Volume = vol.Fields("Volume")
Vol.MoveFirst
Do Until vol.EOF = True
If QueryDef.Name = Volume Then
DoCmd.OpenQuery
Else MsgBox("The query does not exist")
vol.MoveNext
Loop
End Sub
I've searched the internet for a few days and can't find any reference to this particular code. I'm sure other users would like to know how to do this. I'm a novice and still learning VBA so any help you can provide is greatly appreciated.
Your code will loop through, even if you found your query and you do not pass the Query-Name to the OpenQuery command... This won't work...
The collection CurrentDb.QueryDefs knows all existing queries, but there is no "Exists" or "Contains" method.
So: The approach would be a loop (as you tried it) or an Error handling.
It's quite a time ago since I've coded with VBA, but I think you could try:
On Error Resume Next
DoCmd.OpenQuery "YourQueryName"
If Err Then
MsgBox("The query does not exist!")
Err.Clear
End If
On Error Goto 0
I recommend using full DAO in VBA to accomplish your goal. DoCmd.OpenQuery is really a VBA function that mimics the Macro RunQuery action. You don't get much control or true error handling capability.
Here is a complete code function that
Gives you an example of how to select all or some records from your table that lists the queries, including the ability to only select "Active" records, and even sort them in a particular execution sequence
Handles the instances where the query name in your table does not exist
Allows you to display a message about any errors that occur
Allows you to return an exit code to the calling procedure so that you can possibly act on the results of running these queries (such as choosing not to do the next step in your code if this function encounters an error of any kind (returns a non-zero value)
Here is the code. You will need to modify the SQL statement for your correct table name and field names, but this should be a good example to get you on your way.
Public Function lsProcessQuerySet() As Long
On Error GoTo Err_PROC
Dim ErrMsg As String
Dim db As DAO.Database
Dim rstEdits As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim mssql As String
Dim ReturnCode As Long
Set db = CurrentDb()
'============================
'Select the list of Queries you want to process
'============================
mssql = "SELECT tblQueryList.ID, tblQueryList.QueryName, "
mssql = mssql & "tblQueryList.QueryShortDesc "
mssql = mssql & "FROM tblQueryList "
mssql = mssql & "WHERE tblQueryList.QueryActive = True "
mssql = mssql & "ORDER BY tblQueryList.SortOrder;"
Set rstEdits = db.OpenRecordset(mssql, dbOpenDynaset)
DoCmd.Hourglass True
'============================
'Execute each query, allowing processing to continue
'if the query does not exist (an error occurs)
'============================
Do While Not rstEdits.EOF
Set qdf = db.QueryDefs(rstEdits("QueryName"))
qdf.Execute dbSeeChanges
ResumeNextEdit:
rstEdits.MoveNext
Loop
rstEdits.Close
Exit_PROC:
lsProcessQuerySet = ReturnCode
Set qdf = Nothing
Set rstEdits = Nothing
db.Close
Set db = Nothing
DoCmd.Hourglass False
Exit Function
Err_PROC:
Select Case Err.Number
Case 3265 'Item Not Found in this Collection
ReturnCode = Err.Number
ErrMsg = "Query Not Found:" & vbCrLf & vbCrLf
ErrMsg = ErrMsg & rstEdits("QueryName")
DoCmd.Hourglass False
MsgBox ErrMsg, vbOKOnly + vbCritical, "Function lsProcessQuerySet"
Resume ResumeNextEdit
Case Else
ReturnCode = Err.Number
ErrMsg = "Error: " & Err.Number & vbCrLf
ErrMsg = ErrMsg & Err.Description
DoCmd.Hourglass False
MsgBox ErrMsg, vbOKOnly + vbCritical, "Function lsProcessQuerySet"
Resume Exit_PROC
End Select
End Function
The answer of #Shnugo is already good. Just to give you a complete VBA function, this should be working for you.
Public Sub MySub()
On Error GoTo err_mySub
Dim db as Database
Dim vol as Recordset
Set db = CurrentDb()
Set vol = db.OpenRecordset("FacilityVolume", dbOpenDynaset) ' I don't know if you want to run all queries of the table "FacilityVolume".
'So maybe you could also use something like "SELECT Volume FROM FacilityVolume WHERE Volume LIKE ""*10*"""
Vol.MoveFirst
Do Until vol.EOF = True
DoCmd.OpenQuery vol!Volume
vol.MoveNext
Loop
exit_MySub:
Exit Sub
err_MySub:
If Err.Number = 7874 Then
MsgBox "The Query """ & Vol!Volume & """ wasn't found."
Resume Next
Else
MsgBox Err.Description
Resume exit_MySub
End If
End Sub
I have code written to pull a specific file from a folder, insert it into an attachment field (local_attachment) and which creates a new record in table TEMP_attachment. I am trying to pull all the files from a folder and have them each be a new record in the table but I keep running into issues where I either pull all the files and they all go into one record, or it won't pull any. Thank you for your help!!!
Here is my code:
Dim x As Long
Dim strFile As String
Dim db As DAO.Database
Dim rs As DAO.Recordset2
Dim rsA As DAO.Recordset2
Dim fld As DAO.Field2
Dim SQL As String
x = 1
strFile = "C:\dev\test_file2.txt"
SQL = "INSERT INTO TEMP_Attachment (ID) "
SQL = SQL & "VALUES (" & x & ")"
DoCmd.RunSQL SQL
Set db = CurrentDb
Set rs = db.OpenRecordset("TEMP_Attachment")
Set fld = rs("local_attachemnt")
'Navigate through the table
Set rsA = fld.Value
rs.Edit
rsA.AddNew
rsA("FileData").LoadFromFile strFile
rsA.Update
rs.Update
The problems with your code can be fixed my taking a more methodical approach. As I see it, you need to find all the files in the folder, add a record for each one, add an attachment record for the file, read the file data into the new record, and generate a unique key for the parent record.
Rather than try to do everything at once, let's break into pieces and take them in reverse order, so we're dealing with the smallest problems first:
First, let's figure out how we are going to generate a key. The easiest way to do this is to use an Autonumber field. Rather than cook up something fancier, I'm going to assume this is the solution you will use. This will make DoCmd.RunSQL unnecessary and simplify the whole operation.
Second, write a routine which adds one file to one record in the database, and make sure this is working. My suggestion would be to create parameters for a recordset to the main table and a path to the file, like so (I have not tested this, that will be your job. I've added error handlers to help you work out any issues):
Private Sub AddFileAttachment(ByRef rs As DAO.Recordset, ByVal sPath As String)
Dim rsAttachments As DAO.Recordset
On Error Goto EH
With rs
'(this will generate a new Autonumber in the main table)
.AddNew
'this will create a new attachment in the field and add it
Set rsAttachments = .Fields("local_attachemnt").Value
With rsAttachments
.AddNew
.Fields("FileData").LoadFromFile sPath
.Update
.Close
End With
'this is what adds the main record
.Update
End With
EH:
With Err
MsgBox .Number & vbcrlf & .Source & vbCrLf & .Description
End With
FINISH:
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not rsAttachments Is Nothing Then
rsAttachments.Close
Set rsAttachments = Nothing
End If
End Sub
And call it like so:
Private Sub cmdTest_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
On Error Goto EH
Set db = CurrentDb
Set rs = db.OpenRecordset("TEMP_Attachment")
AddFileAttachment rs, "C:\dev\test_file2.txt"
Goto FINISH
EH:
With Err
MsgBox .Number & vbcrlf & .Source & vbCrLf & .Description
End With
FINISH:
rs.Close
End Sub
Important! Perfect the first routine before moving on. You should test it until you know it works over and over. You should be able to click the button it is attached to 10 times and each time get a new record with the file attached.
Once you know this is working, you are ready to write the main routine that calls it for each file you are attaching. I will not include that here, but would suggest researching the FileSystemObject. You should be able to find a lot of vba examples for how to get all the files in a folder. You would loop through them and call your routine for each file the same way it is called in the test above, passing in the open recordset.
Since I`m in a develop mode and my front ends requires a lot of updates.
This is my function to check the version when the user try to open on of the front end:
Public Function FEPath(DBName As String)
Dim Conn As New ADODB.Connection
Dim DataConn As New ADODB.Recordset
Dim Comm As String
Dim strPath As String
Dim strDB As String
Dim strVer As String
Dim strExt As String
Comm = " SELECT tblFE.Database, tblFE.Version, tblFE.Extension " & _
" FROM tblFE WHERE tblFE.[Database] = '" & DBName & "';"
Set Conn = CurrentProject.Connection
DataConn.Open Comm, Conn, adOpenKeyset, adLockOptimistic
With DataConn
strDB = ![Database]
strVer = ![Version]
strExt = ![Extension]
strPath = "C:\Databases\" & strDB & " " & strVer & strExt
.Close
End With
Set Conn = Nothing
I need to somehow run a piece of code every 30 minutes, while the front end is open, to check to see if there is a new front end version available for upload. I would then notify the user, close the database, and update to the new version. Right now, version updating is always happening when the database opens. How can this be done?
Thank you.
There's an old trick MS Access programmers use. You use an autoexec macro to open a hidden form when your database launches. Then you can use the Form_Timer event to trigger any code that you want to run every so often.
The TimerInterval form property uses milliseconds, so you could either set it manually to 1800000 (1000 * 60 * 30) or use your hidden form's on_load event to set it. I usually opt for option 2 so it's spelled out in the code somewhere.
Sub Form_Load()
Me.TimerInterval = 1000 * 60 * 30 ' 30 minutes
End Sub
Sub Form_Timer()
' check the front end version here
End Sub
*Note: Setting the TimerInterval in the load event also allows you to set it to 0 (effectively turn it off) when you're developing. I don't expect you'll need to with a 30 minute timer, but when you're running something every 1/4 second, form timers can be a pain to work with while developing other places in your database application.
I have a procedure that relinks all the tables in a database baed on whether or not they are a linked table. Currently this is set up to run automatically as it's set inside an AutoExec macro which calls the function.
The code works but only if I close the database and reopen it. I know that this is because this needs to be done for the new links to take effect but is there anyway around this? Or, failing that, would it be better to make the VBA code close the database and reopen it?
Thanks in advance for the feedback
P.S. Here's the code, in case you're curious:
'*******************************************************************
'* This module refreshes the links to any linked tables *
'*******************************************************************
'Procedure to relink tables from the Common Access Database
Public Function RefreshTableLinks() As String
On Error GoTo ErrHandler
Dim strEnvironment As String
strEnvironment = GetEnvironment
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strCon As String
Dim strBackEnd As String
Dim strMsg As String
Dim intErrorCount As Integer
Set db = CurrentDb
'Loop through the TableDefs Collection.
For Each tdf In db.TableDefs
'Verify the table is a linked table.
If Left$(tdf.Connect, 10) = ";DATABASE=" Then
'Get the existing Connection String.
strCon = Nz(tdf.Connect, "")
'Get the name of the back-end database using String Functions.
strBackEnd = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "\") - 1)))
'Debug.Print strBackEnd
'Verify we have a value for the back-end
If Len(strBackEnd & "") > 0 Then
'Set a reference to the TableDef Object.
Set tdf = db.TableDefs(tdf.Name)
If strBackEnd = "\Common Shares_Data.mdb" Or strBackEnd = "\Adverse Events.mdb" Then
'Build the new Connection Property Value - below needs to be changed to a constant
tdf.Connect = ";DATABASE=" & strEnvironment & strBackEnd
Else
tdf.Connect = ";DATABASE=" & CurrentProject.Path & strBackEnd
End If
'Refresh the table links
tdf.RefreshLink
End If
End If
Next tdf
ErrHandler:
If Err.Number <> 0 Then
'Create a message box with the error number and description
MsgBox ("Error Number: " & Err.Number & vbCrLf & _
"Error Description: " & Err.Description & vbCrLf)
End If
End Function
EDIT
Following on from Gords comments I have added the macro AutoExec method for calling the code below. Anyone see a problem with this?
Action: RunCode
Function Name: RefreshTableLinks()
The most common error in this situation is forgetting to .RefreshLink the TableDef but you are already doing that. I just tested the following VBA code which toggles a linked table named [Products_linked] between two Access backend files: Products_EN.accdb (English) and Products_FR.accdb (French). If I run the VBA code and then immediately open the linked table I see that the change has taken place; I don't have to close and re-open the database.
Function ToggleLinkTest()
Dim cdb As DAO.Database, tbd As DAO.TableDef
Set cdb = CurrentDb
Set tbd = cdb.TableDefs("Products_linked")
If tbd.Connect Like "*_EN*" Then
tbd.Connect = Replace(tbd.Connect, "_EN", "_FR", 1, 1, vbBinaryCompare)
Else
tbd.Connect = Replace(tbd.Connect, "_FR", "_EN", 1, 1, vbBinaryCompare)
End If
tbd.RefreshLink
Set tbd = Nothing
Set cdb = Nothing
End Function
I even tested calling that code from an AutoExec macro and it also seems to work as expected.
One thing you could try would be to call db.TableDefs.Refresh right at the end of your routine to see if that helps.
Edit
The issue here was that the database had a "Display Form" specified in its "Application Options", and that form apparently opens automatically before the AutoExec macro runs. Moving the function call for the re-linking code to the Form_Load event handler for that "startup form" seems a likely fix.