Windowsアカウントの情報を取得する。

Option Explicit

'*****************************************************************
'　アカウント情報の取得
'*****************************************************************
Sub getUserAccount()

    '出力用シートの追加
    Dim sShtNm As String: sShtNm = "UserAccount"
    Call addSheet(sShtNm)

    'SWbemLocatorオブジェクトを作成してWMIに接続
    Dim oWMI As Object
    Set oWMI = CreateObject("WbemScripting.SWbemLocator").ConnectServer
    
    'オブジェクト取得のクエリを実行
    Dim oQrySet As Object
    Set oQrySet = oWMI.ExecQuery("SELECT * FROM Win32_UserAccount")
    
    'アカウント情報取得
    With Sheets(sShtNm)
        .Cells(1, 1) = "Name"
        .Cells(1, 2) = "FullName"
        .Cells(1, 3) = "Caption"
        .Cells(1, 4) = "Domain"
        .Cells(1, 5) = "Description"
        .Cells(1, 6) = "SID"
        .Cells(1, 7) = "AccountType"
        .Cells(1, 8) = "LocalAccount"
        .Cells(1, 9) = "Disabled"
        .Cells(1, 10) = "Lockout"
        .Cells(1, 11) = "PasswordChangeable"
        .Cells(1, 12) = "PasswordExpires"
        .Cells(1, 13) = "PasswordRequired"
        .Cells(1, 14) = "Status"
    
        Dim oUSER As Object
        Dim i As Long
        i = 2
        For Each oUSER In oQrySet
            .Cells(i, 1) = oUSER.Name
            .Cells(i, 2) = oUSER.FullName
            .Cells(i, 3) = oUSER.Caption
            .Cells(i, 4) = oUSER.Domain
            .Cells(i, 5) = oUSER.Description
            .Cells(i, 6) = oUSER.SID
            .Cells(i, 7) = getAcType(oUSER.AccountType)
            .Cells(i, 8) = oUSER.LocalAccount
            .Cells(i, 9) = oUSER.Disabled
            .Cells(i, 10) = oUSER.Lockout
            .Cells(i, 11) = oUSER.PasswordChangeable
            .Cells(i, 12) = oUSER.PasswordExpires
            .Cells(i, 13) = oUSER.PasswordRequired
            .Cells(i, 14) = oUSER.Status
            
            i = i + 1
        Next
        End With
    
    Set oQrySet = Nothing

End Sub

'*****************************************************************
'　アカウントタイプの取得
'------------------------------------------------------------------
'　　第１引数：アカウントタイプの数値
'------------------------------------------------------------------
'　　戻り値　：アカウントタイプの説明
'*****************************************************************
Function getAcType(getVal As Long)

    Select Case getVal
    Case 256: getAcType = "(" & getVal & ")一時的な重複アカウント"
    Case 512: getAcType = "(" & getVal & ")通常アカウント"
    Case 2048: getAcType = "(" & getVal & ")ドメイン間信頼アカウント"
    Case 4096: getAcType = "(" & getVal & ")ワークステーション信頼アカウント"
    Case 8192: getAcType = "(" & getVal & ")サーバー信頼アカウント"
    Case Else: getAcType = "(" & getVal & ")不明"
    End Select
    
End Function

'******************************************************************
'　シートの追加
'------------------------------------------------------------------
'　　第１引数：設定したいシート名
'******************************************************************
Sub addSheet(getShtNm As String)
    
    '右端にシートを追加する
    Worksheets.Add After:=Sheets(Sheets.Count)
    
    'シートの名前を設定
    On Error Resume Next
    Do While True
        ActiveSheet.Name = getShtNm
        If Err.Number = 0 Then
            Exit Do
        Else
            'シート名が重複する場合は末尾に日時を付けて対応
            getShtNm = getShtNm & "_" & Format(Now(), "yyyymmddhhmmss")
            Err.Clear
        End If
    Loop
    On Error GoTo 0

End Sub

　■実行結果