Access VBA DAO | ADO Bloating Database on MakeTable Query - ms-access
I have a process that updates an Access Database from Oracle data three times a day to get latest information. Current production process involves:
Create New Access Table (t1) of Most Current Data
Move Previous Version of Data to backup version (t to t2)
Move Current Data to Main table (t1 to t)
The reason it's done this way is in case the current data fails, users can still access earlier version of data until we can troubleshoot current data or until the next run.
There are many of the processes that we inherited and I am refactoring the process so we can trap and alert errors and stop downstream processes from running when earlier processes fail.
I've developed the following function using DAO so that I can take advantage of Execute to trap errors and bow out of the whole process gracefully. However, this process bloats the database greatly and in all my searching I cannot find a way around this. Most of the research I have done points to clearing out DAO.Recordsets and DAO.QueryDefs, neither of which I deal with in the DDL statements. I created a similar function with ADO as well, but the same issue persists.
Is there any way to clear the temp memory created in Access from this statements after executing so the code can continue without have the DB grow beyond 2GB size limit? Or perhaps it's just better to run the queries with DoCmd.RunSQL and build error trapping with GoTo. I'd like to avoid this but will settle on this if it's the only way.
Function below:
Function ExecuteSQL(db As DAO.Database, sQuery As String) As Boolean
'*******************************************************************
'** Sub: ExecuteSQL
'** Purpose: Stores current copy of Daily Eff Date table from Daily Eff Table1 and backs up previous version in Daily Eff Date2
'** Notes: Requires reference to Microsoft DAO 3.6 Object Library (or equivalent)
'*******************************************************************
Dim wSpace As DAO.Workspace
Set wSpace = DBEngine.Workspaces(0)
On Error GoTo ErrHandler
With wSpace
.BeginTrans
db.Execute sQuery, dbFailOnError
.CommitTrans
ExecuteSQL = True
End With
LeaveExecuteSQL:
wSpace.Close
Exit Function
ErrHandler:
wSpace.Rollback
Resume LeaveExecuteSQL
End Function
Here is an example of how Function is called.
If Not ExecuteSQL(CurrentDb, "Daily Sub ALL") Then 'Bring Submission Data into Access
strSubject = "ERROR in Creating The Daily Effective Date Table"
GoTo LeaveRunProcess
End If
Here is SQL for Daily Sub ALL:
SELECT PRODCT_EFF_DT, Left([DWCFEUL5_DEV_SUB_RPT_STATUS_SUBM_ALL_NM]![PRODUCT_SIC_CD],4) AS Expr1, Left([PRODUCT_SIC_CD],4) AS [SIC Short], INS_RQMT_PRODCT_NO, CMPNY_REGN_NM, PROCESSING_REGION, PROCESSING_RGN_NM, CMPNY_CD, CMPNY_NM, PUC_NAME, UW_REGION_NAME, PUC_NO, CLIENT_NAME, CLIENT_NUMBER, ACCOUNT_NUMBER, DUNS_NUMBER, DUNS_PARENT, PRODUCER_NUMBER, PRODUCER_NAME, PRODUCER_CONTACT, PRODCR_CNTCT_PRSN_NO, PRODUCT_TYPE, BRANCH_TYPE, BRANCH_NAME, DEPT_NO, NEW_DEPT_NO, DEPT_CD, DEPT_NM, NEW_DEPT_NM, NEW_PRFT_CENTR_NO, PROFT_CNTR_NM, NEW_PRFT_CENTR_NM, EXP_POLICY_NO, EXPPOLICYNO10, POLICY_NO, POLICYNO10, PRODCT_ATCHMT_PNT_AMT, DED_AMT, LMT_AMT, PRODCT_EXP_DT, QUOTE_BY_DT, PRODCT_DESIRBLTY, NEW_PRODCR_NM, PRODCT_SUCCESS_CHNC, WIN_CARR_NAME, INCUMBENT_INS_CARR, PRODCT_EFF_MONTH, LINE_OF_BUSINESS, PRODCT_NO, PROFIT_CENTER, EXP_PREMIUM, UNDERWRITER_NAME, EMPL_ID, STATE, LAST_UPDT_TS, PREM_AMT, DT_RECEIVED, DT_RESERVED, DT_ASSIGNED, DT_WORKING, DT_QUOTED, DT_BOUND, DT_ISSUED, DT_BOOKED, DT_MAILED, DT_DECLINED, DT_QUOTE_NOT_WRITTEN, CURR_STATUS, CURR_STATUS_CD, CURR_STATUS_CHG_USR, CURR_STATUS_EFF_DT, UW_ASISTANT_NAME, COMPANY_TYPE, CREATE_DT, CREATE_USR, PRM_FINCG_IND, BNKRPCY_STAT_CD, BRKR_MNSCRPT_FORMS_IND, UNDLYG_CNF_WRITN_IND, PRODUCT_SIC_CD, ACCT_SIC, ACCT_SIC_DESC, ACCT_SIC_PCT, PROG_TYP_CD, EXT_REPT_IND, MOT_TRK_LIAB_FIL, MOT_TRK_CRG_FIL, SUBJ_TO_AUDIT, COMP_RATED_IND, CONSENT_TO_RATE, IND_RISK_RATING, NY_FREE_TRD_ZONE, EPOL_DELIVERED, PAYDEX_SCORE, CREDIT_SCORE, FINANCIAL_STRESS_SCORE, YEARS_IN_BUSINESS, DNB_NO, DNB_NAME, DNB_PARENT_NO, DNB_HEADQUARTERS_NO, DNB_ADDRESS_LINE1, DNB_ADDRESS_LINE2, DNB_ZIPCODE, DNB_CITY, DNB_STATE, DNB_COUNTRY_CODE, COMMERCIAL_CREDIT_SCORE, START_YEAR, CURRENT_CONTROL_YEAR, NAICS_CODE, INSRD_NM, PRODCR_LONG_NAME, SIR_AMOUNT, EMAIL_ADDRS_TXT, SUB_PRODUCER_NO, SUB_PRODUCER_CODE, SUB_PRODUCER_NM, SUB_PRODUCER_ADDRESS_LINE1, SUB_PRODUCER_ADDRESS_LINE2, SUB_PRODUCER_ADDRESS_LINE3, SUB_PRODUCER_CITY, SUB_PRODUCER_STATE, SUB_PRODUCER_ZIPCODE, PRODUCER_PHONE_NO, SHOPPING, ASSOC_NO, VIABILITY_SCORE, POLICY_ISSUED_BY, ASSOCIATE_UW, FEIN_N0, PRODUCER_FEIN
INTO [Daily Eff Date1]
FROM DWCFEUL5_DEV_SUB_RPT_STATUS_SUBM_ALL_NM
WHERE (((PRODCT_EFF_DT)>#1/1/2015#) AND ((NEW_PRFT_CENTR_NM) Not Like "Hawaii"));
NOT AN ANSWER SUPPORT FOR COMMENT
Option Compare Database
Private WithEvents conCUSTOM_CONNECTION As ADODB.CONNECTION
Public Event evtEXECUTEERROR(ByVal pError As ADODB.Error)
Public Event evtEXECUTESUCCESS()
Public Sub INITIALISE_CONNECTION(con As ADODB.CONNECTION)
Set conCUSTOM_CONNECTION = con
End Sub
Private Sub conCUSTOM_CONNECTION_ExecuteComplete(ByVal RecordsAffected As Long, _
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, _
ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, _
ByVal pConnection As ADODB.CONNECTION)
If pError Is Nothing Then
RaiseEvent evtEXECUTESUCCESS
Else
RaiseEvent evtEXECUTEERROR(pError)
End If
End Sub
I have encountered the same issue where my database is bloating on raw data import. VBA is not allowed to call Compact & Repair on a non-split database. Instead of splitting the database and compacting the backend routinely, I decided to use the database object (DAO) to create a temp database, import the data, query from that temp database back to original and then delete the temp database. Base code shown below:
Sub tempAccessDatabaseImport()
Dim mySQL As String
Dim tempDBPath As String
Dim myWrk As DAO.Workspace
Dim tempDB As DAO.Database
Dim myObject
'Define temp access database path
tempPathArr = Split(Application.CurrentProject.Path, "\")
For i = LBound(tempPathArr) To UBound(tempPathArr)
tempDBPath = tempDBPath + tempPathArr(i) + "\"
Next i
tempDBPath = tempDBPath + "tempDB.accdb"
'Delete temp access database if exists
Set myObject = CreateObject("Scripting.FileSystemObject")
If myObject.FileExists(tempDBPath) Then
myObject.deleteFile (tempDBPath)
End If
'Open default workspace
Set myWrk = DBEngine.Workspaces(0)
'DAO Create database
Set tempDB = myWrk.CreateDatabase(tempDBPath, dbLangGeneral)
'DAO - Import temp xlsx into temp Access table
mySQL = "SELECT * INTO tempTable FROM (SELECT vXLSX.*FROM [Excel 12.0;HDR=YES;DATABASE=" & RAWDATAPATH & "].[" & WORKSHEETNAME & "$] As vXLSX)"
'DAO Execute SQL
Debug.Print mySQL
Debug.Print
tempDB.Execute mySQL, dbSeeChanges
'Do Something Else
'Close DAO Database object
tempDB.Close
Set tempDB = Nothing
myWrk.Close
Set myWrk = Nothing
'Delete temp access database if exists
If myObject.FileExists(tempDBPath) Then
'myObject.deleteFile (tempDBPath)
End If
End Sub
This should probably only be a comment, but I don't have the privileges for that.
"Compact & Repair"ing a database will help with size issues. You can use the Access visual interface to do that on a regular basis or programatically:
https://msdn.microsoft.com/en-us/library/office/bb220986(v=office.12).aspx
Compressing the file (only works on NTFS) will reduce the physical hard drive space occupied (as with ZIP or RAR) while improving speed with hard-drive access (fewer spins in the case of hard disks, and less bytes to read). You can even apply NTFS compression to a file on a network share.
Just today I further reduced the size of an Access database by simply copying all of the objects (it only consists of tables) to a new database file. So it became several times smaller even though I had already compacted it.
I said it's only a comment since it only helps, not solve every side of the problem in every way.
If you can, using append queries instead of make table ones might be worth trying too.
Related
WIA with Access VBA slow
I have a macro running in MS Access 2013 which was created to scan documents from an HP Scanjet Enterprise Flow 7500 scanner, save the results as a PDF and automatically email the file to someone else in our organization. The macro itself runs as it should, however compared to the HP software which comes with the scanner, the scanning portion of the macro takes much longer. With the HP software, the time to scan 23 pages was about 30 seconds. With the macro, I had about 3-4 sheets scanned in that time. Please find below the code I'm using to control the scanner. Does anyone see anything that could be improved or changed to increase the speed of execution? Const WIA_FORMAT_JPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}" Private Sub cmdOK_Click() Dim intPages As Integer 'number of pages Dim img As wia.ImageFile Dim strPath As String Dim strPathImg As String Dim strFileJPG As String Dim txt_id As String Dim strRPTScan As String strPath = "H:\Scan\" 'set path to save files strPathImg = "H:\Scan\Images\" intPages = 1 On Error GoTo ErrorHandler 'scan ScanStart: Dim DialogScan As New wia.CommonDialog Dim DPI As Integer Dim PP As Integer Dim l As Integer Dim Scanner As wia.Device Dim intVerticalExtent As Integer Dim intOneTwoSided As Integer Set Scanner = DialogScan.ShowSelectDevice(wia.WiaDeviceType.ScannerDeviceType, False, False) 'Set page length Select Case fraPaperFormat Case 1 intVerticalExtent = 1650 strRPTScan = "rptScan11" Case 2 intVerticalExtent = 2100 strRPTScan = "rptScan14" End Select 'Set single or two-sided scanning Select Case fraSingleTwoSided Case 1 intOneTwoSided = 1 Case 2 intOneTwoSided = 5 End Select 'Set scanner properties depending on userform letter format values With Scanner .Properties("3088").Value = intOneTwoSided 'determined above .Items(1).Properties("Horizontal Resolution").Value = 150 .Items(1).Properties("Vertical Resolution").Value = 150 .Items(1).Properties("6149").Value = 0 'x point to start scan .Items(1).Properties("6150").Value = 0 'y point to start scan .Items(1).Properties("Horizontal Extent").Value = 1275 .Items(1).Properties("Vertical Extent").Value = intVerticalExtent 'determined above End With 'Start Scan if err number -2145320957 Scan document finish Do While Err.Number <> -2145320957 'error number is ADF status don't feed document On Error GoTo here Set img = Scanner.Items(1).Transfer(WIA_FORMAT_JPEG) strFileJPG = strPathImg & CStr(intPages) & ".jpg" img.SaveFile (strFileJPG) 'save files .jpg in temp folder DoCmd.SetWarnings False DoCmd.RunSQL "insert into scantemp (picture) values ('" & strFileJPG & "')" 'insert picture temp to table scan temp intPages = intPages + 1 'add number pages here: Loop 'after finish scan start convert to pdf Any help would be appreciated.
Obviously, the HP application can do a faster job than any VBA code, as the HP application can probably command the scanner to scan all the pages in the ADF, and you're just doing it one by one. As far as I know, using WIA, you can't work around this. One way you might be able to optimize your code, is to first scan all the images and add them to a collection, then to save all the files in the collection to temporary files, then add them to the database in a single query, instead of processing each image separately. A more optimized scanning solution would implement multithreading to scan and process scans simultaneously. VBA has no native implementation of multithreading, but there are a couple of solutions around there on the web, each having their own limitations.
Inserting records in MS Access by means of macros
Good evening! At this moment I'm learning to work in MS Access for my job purposes. I gained some understanding of the program's basics, such as creating tables or making easy forms (though not yet working ideally), and by now I've got stuck in solving the following task. I have a database BooksDatabase, which consists of three tables: Books, Authors and AuthorsInfo. First one contains information about books (name, genre, country, release year etc.), third one is about authors (first name, last name etc.) and the second one links ever book with its author(s). The task is to import data from text file to those tables, so that it would be almost automatic. I understand how to import files to MS Access (at least, the ones of *.txt extension) and I do this into the table BooksToImport, but I have some difficulties with inserting imported data. Here is the code of my function ImportBooks(), which I execute from macros of the same name: ' Procedure which imports data about books from the table BooksToImport Function ImportBooks() Dim dbBooks As Database Dim rstImBooks, rstBooks, rstAuthors, rstBALink As DAO.Recordset Dim codeI, codeB, codeA, codeL As Variant 'initializing database Set dbBooks = CurrentDb Set rstImBooks = dbBooks.OpenRecordset("Query_BooksToImport",dbOpenDynaset) 'receiving data from query 'checking if the query has any records If rstImBooks.RecordCount = 0 Then MsgBox "There are no records for importing!", vbInformation, "Attention!" rstImBooks.Close Set dbBooks = Nothing Exit Function End If 'if it's OK, we're making a loop on query's records rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset) rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset) rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset) rstImBooks.MoveLast rstImBooks.MoveFirst Do While rstImBooks.EOF = False 'checking if there is a book in out database with the same name as in imported data codeB = DLookup("[ID]","[Books]","[BookName] = '" & rstImBooks![BookName] & "'") If IsNull(codeB) Then 'inserting new record With rstBooks .AddNew ![BookName] = rstImBooks![BookName] .Update .Bookmark = .LastModified codeB = ![ID] End With End If 'in much the same way we're treating the data about authors and making the links rstImBooks.MoveNext Loop rstImBooks.Close rstBooks.Close rstAuthors.Close rstBALink.Close Set dbBooks = Nothing End Function I have two problems with this function: method .AddNew for rstBooks is not working — MS Access shows me a message with error 438 ("Object doesn't support this property or method"); also I cannot assign variable rstBALink to the recordset because compiler says "Invalid use of property". So my question is this: how should I solve these two problems? What do I do wrong that my function is not working properly?
A few issues with your code that I see. These may or may not fix your problem. Your declarations are implicit, meaning you aren't being specific with your code about what your recordset objects are. Instead of using: Dim rstImBooks, rstBooks, rstAuthors, rstBALink As DAO.Recordset Try: Dim rstImBooks As DAO.Recordset Dim rstBooks As DAO.Recordset Dim rstAuthors As DAO.Recordset Dim rstBALink As DAO.Recordset You can put them all on one line separated by commas, but you still need to declare the type for each or Access will assume it's a variant. Secondly, recordset objects need to be created using the Set keyword, not by using an = alone. This was done correctly in the top portion of your code, but is incorrect here: rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset) rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset) rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset) Should be: Set rstBooks = dbBooks.OpenRecordset("Books",dbOpenDynaset) Set rstAuthors = dbBooks.OpenRecordset("AuthorsInfo",dbOpenDynaset) Set rstBALink = dbBooks.OpenRecordset("Authors",dbOpenDynaset) I think that will solve your issues, but I didn't review every line of your code admittedly. Let me know if you still have problems. EDIT: Found a typo: rstBALink = dbBoks.OpenRecordset("Authors",dbOpenDynaset) Should be: Set rstBALink = dbBooks.OpenRecordset("Authors",dbOpenDynaset) (missed an 'o' in dbBooks)
Using ADODB.Recordset.Index when connecting to MySQL ODBC in VB6
I am working on a system that has been in use since the 90's. Written in VB6, it was originally setup to utilize an Access Database and the JET driver. Now, since we have clients running up against the 2GB file size limit on Access DBs, we are looking into converting everything over to mySQL. Unfortunately, everything in the system that was written prior to about 5 years ago is using this type of logic: Dim rst As New ADODB.Recordset rst.ActiveConnection = cnn rst.Open "table" rst.Index = "index" rst.Seek Array("field1", "field2"), adSeekFirstEQ rst!field1 = "something new" rst.Update The newer code is using SQL commands like SELECT, UPDATE, etc. So, what we're hoping to do is to phase in the new mySQL DBs for our clients - get them the DB setup but using all the old code. The problem is that I can't use Index when using the SQL db... everything else seems to work fine except for that. I get the error: #3251: Current provider does not support the necessary interface for Index functionality. Is there something I'm missing? Is there another way to so a Seek when using SQL so that I can sort by my Index? Or will I have to go in and change the entire system and remove all the Seek logic - which is used THOUSANDS of times? This is particularly an issue for all of our Reports where we might have a Table with an Index where Col 1 is sorted ASC, Col 2 is sorted DESC, Col 3 is ASC again and I need to find the first 5 records where Col 1 = X. How else would you do it?
Since, as you posted, the DB doesn't support Seek or Index, you're kind of out of luck as far as that is concerned. However, if you really must use seek /index I'd suggest importing the result of the SQL query into a local .mdb file and then using that to make the recordset work like the rest of the code expects. This is slightly evil from a performance point of view, and honestly it may be better to replace all the seeks and index calls in the long run anyways, but at least it'll save you time coding. For creating the local db you can do: Function dimdbs(Temptable as String) Dim tdfNew As TableDef Dim prpLoop As Property Dim strDbfullpath As String Dim dbsn As Database Dim idx As Index Dim autofld As Field 'PARAMETERS: DBFULLPATH: FileName/Path of database to create strDbfullpath = VBA.Environ$("TMP") & "\mydb.mdb" If Dir(strDbfullpath) <> "" Then Set dbsn = DBEngine.Workspaces(0).OpenDatabase(strDbfullpath) Else Set dbsn = DBEngine.CreateDatabase(strDbfullpath, dbLangGeneral) End If Set tdfNew = dbsn.CreateTableDef(Temptable) With tdfNew ' Create fields and append them to the new TableDef ' object. This must be done before appending the ' TableDef object to the TableDefs collection of the ' database. Set autofld = .CreateField("autonum", dbLong) autofld.Attributes = dbAutoIncrField .Fields.Append autofld .Fields.Append .CreateField("foo", dbText, 3) .Fields.Append .CreateField("bar", dbLong) .Fields.Append .CreateField("foobar", dbText, 30) .Fields("foobar").AllowZeroLength = True Set idx = .CreateIndex("PrimaryKey") idx.Fields.Append .CreateField("autonum") idx.Unique = True idx.Primary = True .Indexes.Append idx Debug.Print "Properties of new TableDef object " & _ "before appending to collection:" ' Enumerate Properties collection of new TableDef ' object. For Each prpLoop In .Properties On Error Resume Next If prpLoop <> "" Then Debug.Print " " & _ prpLoop.Name & " = " & prpLoop On Error GoTo 0 Next prpLoop ' Append the new TableDef object to the Northwind ' database. If ObjectExists("Table", Temptable & "CompletedCourses", "Userdb") Then dbsn.Execute "Delete * FROM " & Temptable & "CompletedCourses" Else dbsn.TableDefs.Append tdfNew End If Debug.Print "Properties of new TableDef object " & _ "after appending to collection:" ' Enumerate Properties collection of new TableDef ' object. For Each prpLoop In .Properties On Error Resume Next If prpLoop <> "" Then Debug.Print " " & _ prpLoop.Name & " = " & prpLoop On Error GoTo 0 Next prpLoop End With Set idx = Nothing Set autofld = Nothing End Function to find and delete it later you can use the following: Function DeleteAllTempTables(strTempString As String, Optional tmpdbname As String = "\mydb.mdb", Optional strpath As String = "%TMP%") Dim dbs2 As Database Dim t As dao.TableDef, I As Integer Dim strDbfullpath If strpath = "%TMP%" Then strpath = VBA.Environ$("TMP") End If strDbfullpath = strpath & tmpdbname If Dir(strDbfullpath) <> "" Then Set dbs2 = DBEngine.Workspaces(0).OpenDatabase(strDbfullpath) Else Exit Function End If strTempString = strTempString & "*" For I = dbs2.TableDefs.Count - 1 To 0 Step -1 Set t = dbs2.TableDefs(I) If t.Name Like strTempString Then dbs2.TableDefs.Delete t.Name End If Next I dbs2.Close End Function To import from SQL to that DB you'll have to get the recordset and add each record in using a for loop (unless it's a fixed ODBC connection, i think you can import directly but I don't have example code) Dim formrst As New ADODB.recordset Set mysqlconn = New ADODB.Connection Dim dbsRst As recordset Dim dbs As Database 'opens the ADODB connection to my database Call openConnect(mysqlconn) 'calls the above function to create the temp database 'Temptable is defined as a form-level variable so it can be unique to this form 'and other forms/reports don't delete it Call dimdbs(Temptable) Me.RecordSource = "SELECT * FROM [" & Temptable & "] IN '" & VBA.Environ$("TMP") & "\mydb.mdb'" Set dbs = DBEngine.Workspaces(0).OpenDatabase(VBA.Environ$("TMP") & "\mydb.mdb") Set dbsRst = dbs.OpenRecordset(Temptable) Set formrst.ActiveConnection = mysqlconn Call Selectquery(formrst, strSQL & strwhere & SQLorderby, adLockReadOnly, adOpenForwardOnly) With formrst Do Until .EOF dbsRst.AddNew dbsRst!foo = !foo dbsRst!bar = !bar dbsRst!foobar = !foobar dbsRst.Update .MoveNext Loop .Close End With dbsRst.Close Set dbsRst = Nothing dbs.Close Set formrst = Nothing You'll have to re-import the data on save or on form close at the end, but at least that will only need one SQL statement, or you can do it directly with the ODBC connection. This is by far less than optimal but at least you can couch all this code inside one or two extra function calls and it won't disturb the original logic. I have to give huge credit to Allen Browne, I pulled this code from all over the place but most my code probably comes from or has been inspired by his site (http://allenbrowne.com/)
Who wants to use VB6? Nevertheless... When you do not specify Provider, you can't use Index property. As far as i know only OleDb for MS Jet supports *Seek* method and *Index* property. Please read this: Seek method - http://msdn.microsoft.com/en-us/library/windows/desktop/ms675109%28v=vs.85%29.aspx Index property - http://msdn.microsoft.com/en-us/library/windows/desktop/ms675255%28v=vs.85%29.aspx ConnectionString property - http://msdn.microsoft.com/en-us/library/windows/desktop/ms675810%28v=vs.85%29.aspx Provider property - http://msdn.microsoft.com/en-us/library/windows/desktop/ms675096%28v=vs.85%29.aspx For further information, please see: http://msdn.microsoft.com/en-us/library/windows/desktop/ms681510%28v=vs.85%29.aspx [EDIT] After your comments... I would strongly recommend to download and install Visual Studio Express Edition and use VB.NET instead VB6. Than install ADO.NET MySQL Connector and re-write application, using the newest technology rather than torturing yourself with ADODB objects, etc. Examples: Connecting to MySQL databases using VB.NET [/EDIT]
Exporting an array of custom objects into Access table
I have a timesheet system in excel with 3 rows (standard time, overtime, double time) for each of our (100+) employees, and one column for each cost code on the site. This ends up being a giant matrix, most of which is empty. My solution is to basically create an employee datatype which stores the employee information and hours for a single cost code. Public Type Employee Name As String Trade(1 To 3) As String EmpNum As Long Comment As String AddOns(1 To 3) As Single Allowance(1 To 3) As Single Contract As Long CostCode As Long STHours As Single OTHours As Single DTHours As Single WorkDate As Date End Type I can process the spreadsheet and organize the information in excel as an array of employee-type objects, but I'm not familiar with how to export this into Access, and most questions relate to exporting from excel cells to Access. I can obviously put these objects into cells on another worksheet and do it that way, but it seems like there should be a better way. Currently my best guess is something like this: Insert data form Excel to Access 2010 using VBA but then I'd be making 100+ updates to the table for each export. Is there an efficient way to create a table object in VBA, populate it with the array information, and then append it to the end of my table in Access in a single update? Thanks. -Sean
The easiest way is to create a table link in Access. Table links look like tables in the rest of Access, but the data is stored externally. The data could be inside another Access database, or inside a SQL Server database, or what have you. In particular, the data can be in an Excel spreadsheet. Define a table in Excel that contains the data in the format that's right for your Access application. Then build a table link in Access that links back to the table you defined in Excel. When you update the Excel table, the updated results will automatically appear the next time you reference the table link in Access.
thanks for the help from everyone ... I just wanted to share what I came up with for a solution. I ended up building a function to insert one object into the database ... copied and modified from the interwebs. Code below, cheers! Public Function InsertTimeRecord(EmpData As Employee) As Boolean Dim SaveTime As Date Dim db As DAO.Database Dim rs As DAO.Recordset '//Database Location Const DB_LOCATION = "C:\access\KMP Tracker.mdb" '//If errors occur the function will exit with a return value of false (insertion failed) On Error GoTo ErrHandler: '//Table has a datecreated/datemodified timestamp for each record SaveTime = Now '//Open Database If db Is Nothing Then Set db = DAO.Workspaces(0).OpenDatabase("C:\access\KMP Tracker.mdb") 'Removed DB_LOCATION End If '//Open Table If rs Is Nothing Then Set rs = db.OpenRecordset("Timesheet Data", dbOpenDynaset) End If '//Create a new record With rs .AddNew ![EmpName] = EmpData.Name ![Trade1] = EmpData.Trade(1) ![Trade2] = EmpData.Trade(2) ![Trade3] = EmpData.Trade(3) ![EmpNum] = EmpData.EmpNum ![Comment] = EmpData.Comment ![AddOns1] = EmpData.AddOns(1) ![AddOns2] = EmpData.AddOns(2) ![AddOns3] = EmpData.AddOns(3) ![Allowance1] = EmpData.Allowance(1) ![Allowance2] = EmpData.Allowance(2) ![Allowance3] = EmpData.Allowance(3) ![Contract] = EmpData.Contract ![CostCode] = EmpData.CostCode ![STHours] = EmpData.STHours ![OTHours] = EmpData.OTHours ![DTHours] = EmpData.DTHours ![WorkDate] = EmpData.WorkDate ![DateSubmitted] = SaveTime '//Insert Record into Database .Update InsertMachineHoursRecord = True '//SUCCESSFUL INSERTION End With '//Note that we use recordset in this example, but equally effective '// is to create an update query command text and simply run the update query: '// (INSERT INTO Table (Field1, Field2) VALUES (Value1, Value2); '//Make sure we have closed the database My_Exit: rs.Close Set rs = Nothing db.Close Set db = Nothing Exit Function ErrHandler: MsgBox Err.Description Resume My_Exit End Function
How to get count of db recordsets/references (to debug err #3048 - can't open more databases)?
I started getting error 3048 - Can't open more databases. I seem to have tamed it by implementing a single, static database variable in a function "dbLocal()" after David Fenton's example here. I would still like to monitor the number of database references to see how close I am getting to the 2048 limit in Access. I have tried to use .Recordsets.Count but it always returns zero. How can I determine the reference/recordset count being used internally by Access? One place I've tried to look at it is in the "dbLocal()" function. Stripped down to less-than-bare-minimum here (in my code I use Fenton's full example), I'm trying this: Public Function dbLocal() As DAO.Database Static dbCurrent As DAO.Database If dbCurrent Is Nothing Then Set dbCurrent = CurrentDb() End If Set CurDb = dbCurrent Debug.Print dbCurrent.Recordsets.Count End Function but it always prints zero. Even if it worked, it's not what I really want, because (if I am understanding correctly) Access is maintaining its own accounting that includes references due to queries, combo-boxes, etc., whereas my static variable would only "know about" references due to VBA statements explicitly using this dbLocal() function. Is there a way to get a peek at Access' internal accounting to know how close I might be to exhausting the 2048 maximum? In case it matters: Windows XP Pro SP3; Access 2010 32-bit version 14.0.6024.1000 SP1 MSO 14.0.6112.5000.
One way to do it is to just keep opening recordsets until you get an error: Function TablesAvailable() As Integer Dim i As Integer, rs As DAO.Recordset, rsColl As Collection On Error GoTo Err_TablesAvailable Set rsColl = New Collection Do While i < 4096 i = i + 1 Set rs = CurrentDb.OpenRecordset("SELECT 1") rsColl.Add rs Loop Exit_TablesAvailable: For Each rs In rsColl rs.Close Set rs = Nothing Next rs Exit Function Err_TablesAvailable: Select Case Err.Number Case 3048 'Cannot open any more databases. TablesAvailable = i Case Else MsgBox Err.Number & ": " & Err.Description End Select Resume Exit_TablesAvailable End Function