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
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 have the below code working for me provided the "Model_data.xlsm" file is stored in my hard drive. Is it possible if Access can get the data from "model_data.xlsm" stored in Sharepoint?
Private Sub Update_manu_data_Click()
Dim strXls As String
strXls = CurrentProject.Path & Chr(92) & "Model_data.xlsm"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Manufacturing_data", _
strXls, True, "Combined!"
End Sub
Finally I did find a workaround for this issue.
I Created a private function in access to download the Excel file from SP and then used the Transferspread sheet function to retrieve the data into access table.
Below is the code i used to download the Excel file in SP using access Vba
Private Sub Command2_Click()
Dim Ex As Object
Dim Acc As Object
Dim strXls As String
Set Ex = CreateObject("Excel.Application")
Set Acc = Ex.Workbooks.Open("https://Sharepoint File link")
Ex.Visible = False
Acc.SaveAs "C:\Users\.......\test.xlsx"
Acc.Close
Ex.Quit
strXls = CurrentProject.Path & Chr(92) & "C:\Users\.......\test.xlsx"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "Tablename", _
strXls, True, "Sheet(1)!"
End Sub
Sub ConnectToExcel()
Dim strSharePointPath As String
Dim strExcelPath As String
Dim strConnectionString As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
' Set the SharePoint path and Excel file name
strSharePointPath = "http://yoursharepointurl.com/YourSharePointFolder/"
strExcelPath = "YourExcelFile.xlsx"
' Build the connection string
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"WSS;IMEX=0;RetrieveIds=Yes;" & _
"DATABASE=" & strSharePointPath & ";" & _
"LIST=" & strExcelPath & ";"
' Open the connection
Set cnn = New ADODB.Connection
cnn.Open strConnectionString
' Open a recordset
Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM [Sheet1$]", cnn
' Loop through the recordset and display the data
Do While Not rs.EOF
Debug.Print rs.Fields(0).Value
rs.MoveNext
Loop
' Clean up
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
End Sub
I'm trying to write record set contents to excel sheet. My code is not working when trying to move record set contents to Movefirst. My vba code
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
strSQL = "SELECT * FROM " & qrytable & ""
rst.Open strSQL, cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
Set wsSheet1 = wb.Sheets(conSHT_NAME)
wsSheet1.Cells.ClearContents
wsSheet1.Select
For i = 1 To rst.Fields.Count
wsSheet1.Cells(1, i) = rst.Fields(i - 1).Name
Next i
If rst.EOF Then
MsgBox "inside rst"
rst.MoveFirst
wsSheet1.Range("a2").CopyFromRecordset rst
End If
wsSheet1.Columns("A:Q").EntireColumn.AutoFit
rst.Close
The condition If rst.EOF is becomes true and when i'm trying to move record set to rst.Movefirst the debugging control is moving out of the method and moving to the method from where i'm calling this method and not writing contents to excel.
Test for a null recordset with the following:
If (rst.BOF And rst.EOF) Then
rst.Close: set rst = Nothing
Else
rst.MoveFirst
rst.CopyFromRecordset rst
End If
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
The following code run a stored procedure based on a combobox that is selected in a form. I need to display the results in a form in Access. Here is the code:
Dim Cmd1 As ADODB.Command
Dim lngRecordsAffected As Long
Dim rs1 As ADODB.Recordset
Dim intRecordCount As Integer
'-----
Dim cnnTemp As ADODB.Connection
Set cnnTemp = New ADODB.Connection
cnnTemp.ConnectionString = "DRIVER=SQL Server;SERVER=****;" & _
"Trusted_Connection=No;UID=****;PWD=****;" & _
"Initial Catalog=IKB_QA;"
'Open Connection
cnnTemp.Open
Set Cmd1 = New ADODB.Command
Cmd1.ActiveConnection = cnnTemp
'---
With Cmd1
Dim localv As Integer
localv = [Forms]![start]![Selection]![cat_code]
.CommandText = "dbo.ix_spc_planogram_match"
.CommandType = adCmdStoredProc
.Parameters.Refresh
.Parameters("#catcode").Value = localv
Set rs1.Open = Cmd1.Execute(localv)
End With
End Sub
It's unclear to me which part of this problem you're having trouble with but maybe it's the binding part.
You can bind a form to an ADO recordset using the following code:
Set Me.Recordset = rs1
Just make sure your form has controls on it bound to the fields which will be in your recordset.