I am using DoCmd.TransferSpreadsheet to populate a table. This command is being called using a button on a form. After the transfer is complete I want to tell the user how many records were added. To try and accomplis this I use db.OpenRecordset("select * from tblImport")
then MsgBox(rs.RecordCount)
The problem is that the record count is being called before the transfer is complete. Is there anyway to call this synchronously?
Here is the complete code
Private Sub cmdVIT_Click()
On Error Resume Next
Dim strPath As String
Dim filePicker As FileDialog
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set filePicker = Application.FileDialog(msoFileDialogFilePicker)
With filePicker
.AllowMultiSelect = False
.ButtonName = "Select"
.InitialView = msoFileDialogViewList
.Title = "Select File"
With .Filters
.Clear
.Add "All Files", "*.*"
End With
.FilterIndex = 1
.Show
End With
strPath = filePicker.SelectedItems(1)
Debug.Print strPath
DoCmd.TransferSpreadsheet TransferType:=acImport, SpreadsheetType:=acSpreadsheetTypeExcel12, TableName:="tblImport", FileName:=strPath, HasFieldNames:=True
Set rs = db.OpenRecordset("select * from tblImport")
MsgBox rs.RecordCount & " records"
End Sub
You need an extra line:
Set rs = db.OpenRecordset("select * from tblImport")
'Populate recordset
rs.MoveLast
MsgBox rs.RecordCount & " records"
You want to display the number of rows contained in tblImport. I don't think you need a recordset to give you that information. Try one of these ...
MsgBox CurrentDb.TableDefs("tblImport").RecordCount & " records"
MsgBox DCount("*", "tblImport") & " records"
However if you need or just want to do it with a recordset, use a faster approach for OpenRecordset.
Set rs = db.OpenRecordset("tblImport", dbOpenTable, dbReadOnly)
rs.MoveLast
MsgBox rs.RecordCount & " records"
Related
I need only empty tables in access database. Additionally, it would be great if I can get empty tables from list of tables that I have (part of all tables). But listing all empty tables would work also.
You can use a small VBA function that checks this. Something like:
Function fIsTableEmpty(strTableName As String) As Boolean
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsData As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT COUNT(*) FROM [" & strTableName & "];"
Set rsData = db.OpenRecordset(strSQL)
fIsTableEmpty = True ' start by assuming that there are records
If Not (rsData.BOF And rsData.EOF) Then
If rsData(0) > 0 Then fIsTableEmpty = False
End If
fExit:
On Error Resume Next
rsData.Close
Set rsData = Nothing
Set db = Nothing
Exit Function
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "fIsTableEmpty", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume fExit
End Function
You can use DCount:
Public Function ListEmptyTables()
Dim Table As DAO.TableDef
For Each Table In CurrentDb.TableDefs
If Table.SourceTableName = "" Then
If DCount("*", Table.Name) = 0 Then
Debug.Print Table.Name
End If
End If
Next
End Function
I have an access database that links to 6 tables. These tables are updated weekly and kept in a folder with the date. I would like for my access program to ask the user to select the location of the tables with out specifically using the Linked Table Manager.
The following code will prompt a user for the full path and file name of the database to be linked to. I decided to do this rather than just prompt for a folder. I strongly suggest you look at the connect string for one of your linked tables and make sure no other parameters are specified other than something like ';DATABASE=C:\Foldera\YYMMDD\MyAccessDB.mdb"
Private Function ReLinkTables()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim tdf2 As DAO.TableDef
Dim strConn As String
Dim strNewPath As String
Dim strTableName As String
On Error GoTo ERROR_HANDLER
' Prompt user for new path...
strNewPath = GetFolder
' Exit if none
If strNewPath = "" Then
Exit Function
End If
Set dbs = CurrentDb
dbs.TableDefs.Refresh
' Find all the linked tables...
For Each tdf In dbs.TableDefs
'Debug.Print tdf.Name & vbTab & tdf.Connect
If Len(tdf.Connect) > 0 Then
strTableName = tdf.Name
Debug.Print "Linked Table: " & tdf.Name & vbTab & tdf.Connect
dbs.TableDefs.Delete strTableName ' Delete the linked table
strConn = ";DATABASE=" & strNewPath
Set tdf2 = CurrentDb.CreateTableDef(strTableName, dbAttachSavePWD, strTableName, strConn)
CurrentDb.TableDefs.Append tdf2
Else ' Not a linked table
'Debug.Print "Keep: " & tdf.Name & vbTab & tdf.Connect
End If
Next tdf
Set tdf = Nothing
Set tdf2 = Nothing
dbs.TableDefs.Refresh
dbs.Close
Set dbs = Nothing
MsgBox "Finished Relinking Tables"
Proc_Exit:
Exit Function
ERROR_HANDLER:
Debug.Print Err.Number & vbTab & Err.Description
Err.Source = "Module_Load_SQLSERVER_DATABASE: ReLinkTables at Line: " & Erl
If Err.Number = 9999 Then
Resume Next
End If
MsgBox Err.Number & vbCrLf & Err.Description
Resume Proc_Exit
Resume Next
End Function
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
'.InitialFileName = "Z:\xxxxxxxx" ' You can change to valid start path
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
Debug.Print "User selected path: >" & sItem & "<"
If sItem = "" Then MsgBox "User did not select a path.", vbOKOnly, "No Path"
GetFolder = sItem
Set fldr = Nothing
End Function
Help! I have a database that I'm using to open an Excel template, export the results of a QueryDef to the acitve worksheet, then save that file with a new file name. Sounds easy enough. The problem that I'm running into is getting the results to export into an active worksheet by using DoCmd.TransferSpreadsheet. It does everything that I need it to, except for actually transfering the data... Which means, it's pretty much useless. Any help would be GREATLY appreciated. I'm about to pull my hair out. Thank you in advance.
Creating the QDF
Set qdf = db.CreateQueryDef("" & strCrt, "SELECT [Zones Asset Information].* FROM " & _
"[Zones Asset Information] WHERE [Zones Asset Informaiton].[Invoice Number] " = '" & strCrt & "';")
Opening the Template
Set xlWB = xlApp.Workbooks.Open(WB_PATH)
Set xlWS = xlWB.Sheets(3)
xlWS.Activate
Trying to Export
DoCmd.TransferSpreadsheet acExport, 10, "" & strCrt, , True, "orig data" 'Don't know how to specify Active Worksheet instead of a filename?!?
DoCmd.DeleteObject acQuery, "" & strCrt
Saving the File
sSaveAsFileName = FLDR_PATH & "Accounting_Breakdown_Zones_Invoice_xxxxxx.xlsx"
Debug.Print "sSaveAsFileName: " & sSaveAsFileName
xlWB.SaveAs sSaveAsFileName
There are two ways of exporting data from Access to Excel:
Opening an MsExcel object and using its methods to manipulate the Excel
Exporting data using the TransferSpreadsheet method
You are doing a mix of both, which is why you are not getting the result.
TransferSpreadsheet will export the given query to the specified file, but you cannot specify the worksheet.
If specifying worksheet is important, you will have to do it with an Excel object, and send the information cell by cell, a lot more work, if it justifies the cause.
E Mett, Thank you for the direction. Had to rework the process which doesn't 100% agree with the post title now, but thought I would share in case anyone else needed something similar. Thanks again!!
Private Sub ExportTable_MultipleWB()
Dim db As DAO.Database, rs As DAO.Recordset, rs2 As DAO.Recordset, strFilter As String, strFilter2 As String, _
sSaveAsFileName As String
Dim xlApp As Excel.Application, xlWB As Excel.Workbook, xlWS As Excel.Worksheet
Dim bolIsExcelRunning As Boolean
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT DISTINCT [mytable].[PO Number], [mytable].[Invoice Number] " & _
"FROM [mytable] ORDER BY [mytable].[PO Number], [mytable].[Invoice Number];", dbOpenSnapshot)
rs.MoveFirst
Do While Not rs.EOF
strFilter = rs.Fields(1).Value
strFilter2 = rs.Fields(0).Value
Set rs2 = db.OpenRecordset("SELECT [mytable].* FROM [mytable] WHERE [mytable].[Invoice Number] = '" & strFilter & "';")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
Else
bolIsExcelRunning = True
End If
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open(WB_PATH)
Set xlWS = xlWB.Sheets(3)
xlWS.Activate
With xlWS
For iCols = 0 To rs2.Fields.Count - 1
xlWS.Cells(1, iCols + 1).Value = rs2.Fields(iCols).Name
Next
xlWS.Range(xlWS.Cells(1, 1), _
xlWS.Cells(1, rs2.Fields.Count)).Font.Bold = True
xlWS.Range("A2").CopyFromRecordset rs2
End With
sSaveAsFileName = FLDR_PATH & "myfilename_" & strFilter & "_PO-" & strFilter2 & ".xlsx"
Debug.Print "sSaveAsFileName: " & sSaveAsFileName
xlWB.SaveAs sSaveAsFileName
Set xlWS = Nothing
xlWB.Close False
Set xlWB = Nothing
rs.MoveNext
Loop
rs.Close
rs2.Close
If Not bolIsExcelRunning Then
xlApp.Quit
End If
Set xlApp = Nothing
Set rs = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
qdf.Parameters("fileName") = strFile
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub
As you can see from the code on import I want to store the file name and while it does work it doesn't work exactly how I need it to. When we do work for this client it is 5 files ate a time once a week so I would like it to save all 5 file names however it only saves the last one it imports. My question, is there a way to save each file name to each one ( I doubt that) or can I save all 5 file names to all the records I import instead of just the last file name?
I always have the option of only allowing a single import and making them import and append the table 5 times I just wanted to check to see if there is a more efficent way before doing so.
Thanks in advance for any help in this matter!
There is a problem in your logic. Inside the loop, strFile holds the current file name. So after your loop is finished, only the current (=last) file name is passed on to the query.
I made some changes, so the filenames are now stored in the new variable strFileList, delimited by a ";". Please check, if this is a feasible solution.
Private Sub Command38_Click()
Dim f As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strUpdate As String
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Dim P As String
Dim DeleteEverything As String
' Variable to hold file list
Dim strFileList As String
DoCmd.SetWarnings False
DeleteEverything = "DELETE * FROM [ucppltr]"
DoCmd.RunSQL DeleteEverything
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
f.InitialFileName = "S:\Formware\outfile\ucppt12\Storage"
f.Filters.Clear
f.Filters.Add " Armored TXT Files", "*.asc"
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
strFolder = Left(varItem, Len(varItem) - Len(strFile))
P = strFolder & strFile
DoCmd.TransferText acImportDelim, "UCPP Import Specification", "ucppltr", P, False
'Add file name to file list
strFileList = strFileList & strFile & ";"
Next
End If
strUpdate = "PARAMETERS fileName Text;" & vbCrLf & _
"UPDATE ucppltr" & vbCrLf & _
"Set [File Name] = fileName"
Debug.Print strUpdate
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strUpdate)
'Pass file list to query
qdf.Parameters("fileName") = strFileList
qdf.Execute dbFailOnError
Set qdf = Nothing
Set db = Nothing
Set f = Nothing
MsgBox DCount("*", "ucppltr") & " Records were imported"
End Sub
I have a form (Cobind_frmMain) that allows the user to create a pool of titles that are attached to it. So there is a top level Pool Name (TopLvlPoolName) and on a subform, the titles are added to it. What I need is to issue a Report for each of the titles. I have the report and queries all set up. Right now, the report will show all the titles in one file. The titles are in a field called "CatCode".
What I need is the following:
1. Save each title as a PDF and save it to our server.
2. Open email and attach the PDF.
3. Repeat until all titles are done.
EDIT: This is what I have so far for code and the error message I still get is: "Too Few Parameters" on the Set Recordset line. I'm trying to set the parameter in the strSQL line. I want the PartPoolName (in Cobind_qryReport, a query) to equal the TopLvlPoolName on the open form. The SQL for Cobind_qryReport is listed below:
Private Sub btn_Run_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb
strSQL = "Select * FROM Cobind_qryReport WHERE PartPoolName = " & Me.TopLvlPoolName
Set rs = db.OpenRecordset(strSQL)
On Error GoTo Err_PO_Click
If MsgBox("Do you wish to issue the cobind invites?", vbYesNo + vbQuestion, "Confirmation Required") = vbYes Then
rs.MoveFirst
Do While Recordset.EOF = False
DoCmd.OutputTo acOutputReport, "Cobind_rptMain", acFormatPDF, "K:\OB MS Admin\Postage\CoBind Opportunities\Sent Invites\" & [CatCode] & "_" & [PartPoolName] & "Cobind Invite_" & Format(Now(), "mmddyy") & ".pdf"
DoCmd.SendObject acSendReport, "Cobind_rptMain", acFormatPDF, , , , [CatCode] & "_" & [PartPoolName] & " Cobind Invite", "Please find the cobind invite attached. Response is needed by " & [RSVP] & ". Thank you.", True
Recordset.MoveNext
Loop
End If
Exit_PO_Click:
MsgBox ("It didn't work")
Exit Sub
Err_PO_Click:
MsgBox Err.Description
Resume Exit_PO_Click
End Sub
Cobind_qryReport SQL:
SELECT tblEvents.EventTitle, Cobind_tblPartic.CatCode, Cobind_tblPartic.CodeQty, Cobind_tblPartic.PartPoolName, Cobind_tblTopLvl.RSVP, Cobind_tblPartic.ID
FROM Cobind_tblTopLvl, Cobind_tblPartic INNER JOIN tblEvents ON Cobind_tblPartic.CatCode = tblEvents.EventCode
GROUP BY tblEvents.EventTitle, Cobind_tblPartic.CatCode, Cobind_tblPartic.CodeQty, Cobind_tblPartic.PartPoolName, Cobind_tblTopLvl.RSVP, Cobind_tblPartic.ID
ORDER BY Cobind_tblPartic.ID;
Thank you again for all your help!
You're query Cobind_qryReport has a parameter that you need to set. if you want to know the parameter name try the following code
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs("Cobind_qryReport")
If qdf.Parameters.Count > 0 Then
MsgBox (qdf.Parameters(0).Name)
End If
Update
Since you know you've got a parameter doing select * from Cobind_qryReport it might just be easier to set the parameter and then use the qdf to open the recordset e.g.
Dim rs as DAO.Recordset
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs("Cobind_qryReport")
qdf.Parameters(0).Value = 7832
Set foo = qdf.OpenRecordset()
Note: you can use the parameter name in the place of the ordinal when setting the parametervalue
e.g. qdf.Parameters("Foo").value = 7832