通过VBA获取laccdb文件的内容

Question

我希望能够通过 VBA 查看我的 access 数据库的 laccdb 文件的内容，这样我就可以使用它来提醒用户（通过一个按钮）还有谁在数据库中。

我特别不想使用 3rd 方工具。我试过使用：

Set ts = fso.OpenTextFile(strFile, ForReading)
strContents = ts.ReadAll

如果数据库中只有 1 个用户，这将正常工作。但是对于多个用户来说，它可能会被可能的非 ASCII 字符弄糊涂，并在一次输入后进入这种事情：

有人有什么建议吗？用记事本++打开文件就好了……

---

最终使用的代码如下（我不需要标题，并删除了一些没有使用的代码）：

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

cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & CurrentDb.Name

Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
While Not rs.EOF
    Debug.Print rs.Fields(0)
    rs.MoveNext
Wend

End Sub

Answer 1

我发现这应该有帮助，它实际上并没有读取 ldb 文件，但它包含您需要的信息（来源：https://support.microsoft.com/en-us/kb/198755）：

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

    cn.Provider = "Microsoft.Jet.OLEDB.4.0"
    cn.Open "Data Source=c:\Northwind.mdb"

    cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
    & "Data Source=c:\Northwind.mdb"

    ' The user roster is exposed as a provider-specific schema rowset
    ' in the Jet 4 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

End Sub

Answer 2

我整理了一些代码来读取锁定文件并输出一条消息，列出当前使用系统的用户。

尝试一次读取整个文件似乎会导致 VBA 将字符串视为 Unicode，就像记事本一样，所以我逐个字符地读取并过滤掉非打印字符。

Sub TestOpenLaccdb()
Dim stm As TextStream, fso As FileSystemObject, strLine As String, strChar As String, strArr() As String, nArr As Long, nArrMax As Long, nArrMin As Long
Dim strFilename As String, strMessage As String
strFilename = CurrentProject.FullName
strFilename = Left(strFilename, InStrRev(strFilename, ".")) & "laccdb"

Set fso = New FileSystemObject
Set stm = fso.OpenTextFile(strFilename, ForReading, False, TristateFalse)  'open the file as a textstream using the filesystem object (add ref to Microsoft Scripting Runtime)

While Not stm.AtEndOfStream  'Read through the file one character at a time
    strChar = stm.Read(1)
    If Asc(strChar) > 13 And Asc(strChar) < 127 Then  'Filter out the nulls and other non printing characters
        strLine = strLine & strChar
    End If
Wend
strMessage = "Users Logged In: " & vbCrLf
'Debug.Print strLine
strArr = Split(strLine, "Admin", , vbTextCompare)  'Because everyone logs in as admin user split using the string "Admin"
nArrMax = UBound(strArr)
nArrMin = LBound(strArr)
For nArr = nArrMin To nArrMax   'Loop through all machine numbers in lock file
    strArr(nArr) = Trim(strArr(nArr))  'Strip leading and trailing spaces
    If Len(strArr(nArr)) > 1 Then  'skip blank value at end
            'Because I log when a user opens the database with username and machine name I can look it up in the event log
        strMessage = strMessage & DLast("EventDescription", "tblEventLog", "[EventDescription] like ""*" & strArr(nArr) & "*""") & vbCrLf
    End If
Next
MsgBox strMessage  'let the user know who is logged in
stm.Close
Set stm = Nothing
Set fso = Nothing

End Sub