创建当前访问用户的用户列表

时间:2015-10-20 16:51:31

标签: vba

我正在尝试在Access中创建一个表,其中包含系统中当前用户的计算机名称。

到目前为止我的代码是

Option Compare Database
Option Explicit

Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long

Set cn = CurrentProject.Connection

Dim dbs As Database, tbl As TableDef, fld As Field
Set dbs = CurrentDb

Set tbl = dbs.CreateTableDef("Users")
Set fld = tbl.CreateField("User#", dbText)

' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4.0 OLE DB provider.  You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets

Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")

'Output the list of all users in the current database.

Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name

While Not rs.EOF
    Debug.Print rs.Fields(0), rs.Fields(1), _
    rs.Fields(2), rs.Fields(3)
    rs.MoveNext
Wend

tbl.Fields.Append ?

End Sub

我找到并更新的代码有点工作,但它只输出到即时窗口,debug.print应该,但我需要创建一个包含所有数据的表。

任何帮助都将不胜感激。

提前致谢。

1 个答案:

答案 0 :(得分:2)

知道了,有趣的是之前在这个网站上已经提出这个问题,下次必须尝试更好的搜索。

我的代码如下工作

Option Compare Database
Option Explicit
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
Dim db As Database
Dim rsDao As DAO.Recordset

Set cn = CurrentProject.Connection
Set db = CurrentDb
Set rsDao = db.OpenRecordset("Users", dbOpenTable, dbAppendOnly + dbFailOnError)

' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4.0 OLE DB provider.  You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets

Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")

'Output the list of all users in the current database.
Do While Not rs.EOF
    rsDao.AddNew
    rsDao!User.Value = rs.Fields(0)
    rsDao.Update
    rs.MoveNext
Loop
End Sub

这假设您有一个数据库,其中包含一个名为“Users”的表,其中一列名为“User”,我知道这是非常原始的。

测试它并且它引入了一个用户我,它应该引入数据库中的任何其他用户。

感谢你的帮助Ken。