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
Related
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
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
I am new to VBA and am working on a project which will display all current users who have a particular file open (MS Access). I am trying to populate a listbox with the computer name info but am getting an error when I try to run the button command.rs.Fields(0) is the only field I need as it is the computer name. I just need a list of all computer names connected.
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set cn = CurrentProject.Connection
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
'While Not rs.EOF
'Debug.Print rs.Fields(0), rs.Fields(1), _
'rs.Fields(2), rs.Fields(3)
'rs.MoveNext
'Wend
Do While Not rs.EOF
With List73
.AddItem rs.Fields(0)
End With
Next
End Sub
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set cn = CurrentProject.Connection
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}"
'While Not rs.EOF
'Debug.Print rs.Fields(0), rs.Fields(1), _
'rs.Fields(2), rs.Fields(3)
'rs.MoveNext
'Wend
Do While Not rs.EOF
With List73
.AddItem rs.Fields(0)
End With
Loop
End Sub
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
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