This is my code:
Private Sub Command36_Click()
Dim dbs As DAO.Database
Dim rs As DAO.Recordset
Dim qdef As DAO.QueryDefs
Set dbs = CurrentDb
Set qdef = dbs.QueryDefs("qryGetDecisionFieldOfSelectedRecord")
Set rs = qdef.OpenRecordset
If rs.RecordCount > 0 Then
DoCmd.OpenReport "rptApplicationDeclinedLetter", acViewPreview, "qryApplicationLetter"
End If
End Sub
The compile error is triggered at Set rs = qdef.OpenRecordSet. Apologies if this is too obvious.
Correct this to:
Dim qdef As DAO.QueryDef
Related
I'm trying to build up a collection of dictionaries in VBA. After the collection has been built, it will be converted to JSON, and sent to a web service in a HTTP request.
Because dictionaries are objects, they are added to the collection by reference, not by value. The result is that my collection is made up of identical dictionaries, rather than the individual dictionaries that I wanted.
Dim qdf As DAO.QueryDef
Dim rs As DAO.Recordset
Set qdf = CurrentDb.QueryDefs("qryTutors")
Set rs = qdf.OpenRecordset
Dim tutors As New Collection
If Not (rs.EOF And rs.BOF) Then
Do Until rs.EOF = True
Dim tutor As New Scripting.Dictionary
tutor.Add "TutorName", rs!TutorFirstName.Value & " " & rs!TutorSurname.Value
tutor.Add "TutorEmail", rs!TutorEmail.Value
tutor.Add "TutorSubject", rs!TutorSubject.Value
tutors.Add tutor
tutor.RemoveAll
rs.MoveNext
Loop
End If
txtOutput.Value = JsonConverter.ConvertToJson(tutors)
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
Any help appreciated, thanks.
Use a new dictionary in each iteration:
Dim qdf As DAO.QueryDef
Dim rs As DAO.Recordset
Set qdf = CurrentDb.QueryDefs("qryTutors")
Set rs = qdf.OpenRecordset
Dim tutors As New Collection
Dim tutor As Scripting.Dictionary
If Not (rs.EOF And rs.BOF) Then
Do Until rs.EOF = True
Set tutor = New Scripting.Dictionary
tutor.Add "TutorName", rs!TutorFirstName.Value & " " & rs!TutorSurname.Value
tutor.Add "TutorEmail", rs!TutorEmail.Value
tutor.Add "TutorSubject", rs!TutorSubject.Value
tutors.Add tutor
rs.MoveNext
Loop
End If
txtOutput.Value = JsonConverter.ConvertToJson(tutors)
rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
I am using this code to download certain outlook mail fields into access. This works well however the code is keep on downloading duplicate mails. Is there a way to check for existing records and download records which are not in the table? Your answers would help a lot in my project
Private Sub getml()
Dim rst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim inbox As Outlook.MAPIFolder
Dim inboxItems As Outlook.Items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Set db = CurrentDb
Set OlApp = CreateObject("Outlook.Application")
Set inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set rst= CurrentDb.OpenRecordset("mls")
Set inboxItems = inbox.Items
For Each Mailobject In inboxItems
With rst
.AddNew
!task= Mailobject.UserProperties.Find("taskID")
!tsktml= Mailobject.UserProperties.Find("timeline")
.Update
Mailobject.UnRead = False
End With
End If
Next
Set OlApp = Nothing
Set inbox = Nothing
Set inboxItems = Nothing
Set Mailobject = Nothi
End Sub
I am assuming that TaskID is a numeric unique identifier for tasks, not that familiar with Outlook objects. If so, you can use the following code to first check the task hasn't been imported already.
Private Sub getml()
Dim rst As DAO.Recordset
Dim OlApp As Outlook.Application
Dim inbox As Outlook.MAPIFolder
Dim inboxItems As Outlook.Items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Set db = CurrentDb
Set OlApp = CreateObject("Outlook.Application")
Set inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set rst= CurrentDb.OpenRecordset("mls")
Set inboxItems = inbox.Items
For Each Mailobject In inboxItems
With rst
.FindFirst "task =""" & Mailobject.UserProperties.Find("taskID") & """"
If .NoMatch
.AddNew
!task= Mailobject.UserProperties.Find("taskID")
!tsktml= Mailobject.UserProperties.Find("timeline")
.Update
Mailobject.UnRead = False
End If
End With
End If
Next
Set OlApp = Nothing
Set inbox = Nothing
Set inboxItems = Nothing
Set Mailobject = Nothing
End Sub
I'm trying to create a new table with a VBA macro in Access 2010 to store some output and I am unable to do the basics of just creating said empty table below is the relevant code:
Dim dbs As DAO.Database
Dim emptyTdf As DAO.TableDef
Dim rs, emptyRs As DAO.Recordset
Dim fld, emptyFld As DAO.Field
Dim fldnm As String
Dim fldv As Variant
Dim isEmptyField As Boolean
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("AP")
Set emptyTdf = dbs.CreateTableDef("AP_Empty")
Set emptyFld = emptyTdf.CreateField("HID", dbText, 255)
dbs.TableDefs.Append emptyTdf
The last line sets off the run-time error. I've followed a few tutorials online using the DAO method to create tables and my code doesn't deviate, so I guess it is a syntactical gotcha that I've stumbled on.
You need to append your field to the TableDef before appending the TableDef itself:
Dim dbs As DAO.Database
Dim emptyTdf As DAO.TableDef
Dim rs, emptyRs As DAO.Recordset
Dim fld, emptyFld As DAO.Field
Dim fldnm As String
Dim fldv As Variant
Dim isEmptyField As Boolean
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset("AP")
Set emptyTdf = dbs.CreateTableDef("AP_Empty")
Set emptyFld = emptyTdf.CreateField("HID", dbText, 255)
'Append your created field.
emptyTdf.Fields.Append emptyFld
dbs.TableDefs.Append emptyTdf
'Just so your collections and the db window is refreshed.
dbs.TableDefs.Refresh
Application.RefreshDatabaseWindow
I'm trying to write query/table contents from access to excel using vba. Currently my code is working to open new workbook every time and write the contents instead i need to specify the path of only one workbook to write. How do i specify the path in the code
My Access VBA
Function WriteToExcel()
Dim cnn As ADODB.Connection
Dim rst As New ADODB.Recordset
Dim strSQL As String
Dim strPath As String
Dim ws As Excel.Application
Dim i As Long
'*************************************************
'First stage is to take the first query and place it
'On sheet1
'*************************************************
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
strSQL = "SELECT * FROM query1"
rst.Open strSQL, cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
rst.MoveFirst
Set ws = CreateObject("Excel.Application")
With ws
.Workbooks.Add
.Visible = True
End With
ws.Sheets("sheet1").Select
For i = 0 To rst.Fields.Count - 1
ws.ActiveCell.Offset(0, i).Value = rst.Fields(i).Name
Next
ws.Range("a2").CopyFromRecordset rst
ws.Columns("A:Q").EntireColumn.AutoFit
rst.Close
End Function
I think there is a little confusion because of your variable prefixes. I've taken the liberty of amending your prefixes and answered the problem. You need Workbooks.Open(<<filename goes here>>) in place of Workbooks.Add. So try this code (untested as I do not have Access). Lastly there are other ways to populate Excel with data from Access, like a DataQuery. You might like to play with Excel GUI to investigate.
Function WriteToExcel()
Dim cnn As ADODB.Connection
Dim rst As New ADODB.Recordset
Dim strSQL As String
Dim strPath As String
Dim appXL As Excel.Application
Dim wb As Excel.Workbook
Dim wsSheet1 As Excel.Worksheet
Dim i As Long
'*************************************************
'First stage is to take the first query and place it
'On sheet1
'*************************************************
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
strSQL = "SELECT * FROM query1"
rst.Open strSQL, cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
rst.MoveFirst
Set appXL = CreateObject("Excel.Application")
With appXL
'Set wb = .Workbooks.Add '<--- to create a new workbook
Set wb = .Workbooks.Open("c:\temp\Myworkbook.xlsx") '<--- to open an exisiting workbook
.Visible = True
End With
Set wsSheet1 = wb.Sheets("sheet1")
wsSheet1.Select
For i = 0 To rst.Fields.Count - 1
wsSheet1.ActiveCell.Offset(0, i).Value = rst.Fields(i).Name
Next
wsSheet1.Range("a2").CopyFromRecordset rst
wsSheet1.Columns("A:Q").EntireColumn.AutoFit
rst.Close
End Function
I need a way to return the records affected from a SQL Server stored procedure and display it in a messagebox using VBA in my Access database. The following is the procedure I use to execute all stored procedures within Access...
Public Sub SP(exec As String)
Dim qdf As DAO.QueryDef
Dim strConn As String
strConn = "ODBC;DRIVER=SQL Server;SERVER=;DATABASE=;Trusted_Connection=Yes"
Set qdf = CurrentDb.CreateQueryDef("")
With qdf
.Connect = strConn
.ReturnsRecords = False
.SQL = exec
.Execute
.Close
End With
Set qdf = Nothing
End Sub
Connection, Database and QueryDef all have a .RecordsAffected property.
Try the following:
Public Sub SP(exec As String)
Dim qdf As DAO.QueryDef
Dim strConn As String
strConn = "ODBC;DRIVER=SQL Server;SERVER=;DATABASE=;Trusted_Connection=Yes"
Set qdf = CurrentDb.CreateQueryDef("")
With qdf
.Connect = strConn
.ReturnsRecords = False
.SQL = exec
.Execute
MsgBox Exec & vbCrLf & vbCrLf & .RecordsAffected & " Record(s) Affected."
.Close
End With
Set qdf = Nothing
End Sub