Dim objRoot, objConnection, objCommand, objRSet
Dim strDomain, strComputer, strList, 
Const ADS_SCOPE_SUBTREE = 2

strComputer = Trim(InputBox("NetBIOS-имя компьютера:", "Поиск принтеров, опубликованных в AD"))
If Len(strComputer) > 0 Then
    Set objRoot = GetObject("LDAP://RootDSE")
    strDomain = objRoot.Get("DefaultNamingContext")
    Set objRoot = Nothing
    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Provider = "ADsDSOObject"
    objConnection.Open "Active Directory Provider"
    Set objCommand = CreateObject("ADODB.Command")
    Set objCommand.ActiveConnection = objConnection
    strAttributes = "Location,printerName"
    strCommandText = "SELECT " & strAttributes & " FROM 'LDAP://" & strDomain & _
                    "' WHERE objectCategory='printQueue' AND shortServerName='" & strComputer & "'"
    objCommand.CommandText = strCommandText
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Timeout") = 30
    objCommand.Properties("Sort On") = "printerName"
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    Set objRSet = objCommand.Execute
    If objRSet.RecordCount > 0 Then
        strList = vbNullstring
        objRSet.MoveFirst
        Do Until objRSet.EOF
            For i = 0 To objRSet.Fields.Count - 1
                strList = strList & objRSet.Fields(i).Name & " = " & objRSet.Fields(i).Value & vbNewLine
            Next
            strList = strList & "---" & vbNewLine
            objRSet.MoveNext
        Loop
        WScript.Echo strList
    Else
        WScript.Echo "Ничего не обнаружено."
    End If
    Set objRSet = Nothing
    Set objCommand = Nothing
    objConnection.Close
    Set objConnection = Nothing
End If
WScript.Quit 0

Option Explicit
Dim WMI, sStr, i, cpsys, p,compname
Dim nwo, comp, user
Set nwo = CreateObject("WScript.Network")
comp = LCase(nwo.ComputerName)
'запросить имя удаленного компьютера
comp = InputBox("Введите имя компьютера:", comp)
'проверить доступность компьютера
If Unavailable(comp) Then
    MsgBox "Компьютер недоступен:" & vbCrLf & comp
    comp = ""
       WScript.Quit(0) ' на выход
End If

If Len(comp) < 1 Then WScript.Quit(0) ' на выход


'Соединимся с WMI
On Error Resume Next
set WMI=GetObject("WinMgmts:{impersonationLevel=impersonate}!\\" & comp & "\Root\CIMV2")
If Err <> 0 Then 
 dim obj,objs,admname,admpass
 dim locator
 admname=inputbox("Имя администратора","Введите имя","")
 admpass=inputbox("Пароль администратора","Введите пароль","")
 set locator =Createobject("WbemScripting.SWbemLocator")
 set WMI = locator.ConnectServer(comp,"root\cimv2",admname,admpass)
 Err.Clear 
End if 
Set cpsys = WMI.ExecQuery("SELECT * FROM Win32_ComputerSystem")

For Each p In cpsys
 compname=p.name
 user=p.UserName
next

sStr="Имя компьютера    : "& compname & vbCrLf 'Имя компьютера
sStr=sStr+"Имя пользователя  : " & user & vbcrlf 

Set cpsys = WMI.ExecQuery("SELECT * FROM Win32_Printer")

For Each p In cpsys
  sStr=sStr+"Принтер                    : " & p.Name & vbcrlf 
next

if Wscript.Arguments.Count > 0 then
  Dim fso, tf
  Set fso = CreateObject("Scripting.FileSystemObject") 
  Set tf = fso.CreateTextFile(compname & ".TXT", True)
  tf.WriteLine sStr
  tf.Close
end if

WScript.Echo sStr
WScript.Quit(0) ' на выход

'проверить доступность компьютера в сети
'вернуть True, если адрес недоступен
Function Unavailable(addr)
    Dim wmio, ping, p
    Set wmio = GetObject("WinMgmts:{impersonationLevel=impersonate}")
    Set ping = wmio.ExecQuery("SELECT StatusCode FROM Win32_PingStatus WHERE Address = '" & addr & "'")
    For Each p In ping
        If IsNull(p.StatusCode) Then
            Unavailable = True
        Else
            Unavailable = (p.StatusCode <> 0)
        End If
    Next
End Function

Dim objRoot, objConnection, objCommand, objRSet
Dim strDomain, strOU, strComputer, strList, strTemp, strLog
Dim intCounter, intLeft, intRight, blnHasResult
Dim objFS, objFile, objWShell
Const ADS_SCOPE_SUBTREE = 2

strLog = "Printers_List.log"
Set objRoot = GetObject("LDAP://RootDSE")
strDomain = objRoot.Get("DefaultNamingContext")
Set objRoot = Nothing
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
Set objCommand.ActiveConnection = objConnection
strAttributes = "distinguishedName,shortServerName,Location,printerName"

strOU = Trim(InputBox("Имя подразделения:", "Поиск принтеров, опубликованных в AD"))
strCommandText = "SELECT " & strAttributes & " FROM 'LDAP://" & strDomain & _
                "' WHERE objectCategory='printQueue'"
objCommand.CommandText = strCommandText
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 30
objCommand.Properties("Sort On") = "printerName"
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRSet = objCommand.Execute
If objRSet.RecordCount > 0 Then
    strList = vbNullstring
    objRSet.MoveFirst
    Do Until objRSet.EOF
        blnHasResult = False
        strTemp = objRSet.Fields("distinguishedName").Value
        If Len(strOU) > 0 Then
            If InStr(1, strTemp, "ou=" & strOU & ",", vbtextCompare) > 0 Then
                blnHasResult = True
            Else
                blnHasResult = False
            End If
        Else
            blnHasResult = True
        End If
        If blnHasResult Then
            intCounter = intCounter + 1
            For i = 0 To objRSet.Fields.Count - 1
                If StrComp(objRSet.Fields(i).Name, "distinguishedName", vbtextCompare) <> 0 Then
                    strList = strList & objRSet.Fields(i).Name & " = " & objRSet.Fields(i).Value & vbNewLine
                End If
            Next
            strList = strList & "---" & vbNewLine
        End If
        objRSet.MoveNext
    Loop
    If Len(strList) > 0 Then
        Set objFS = CreateObject("Scripting.FileSystemObject")
        strLog = objFS.BuildPath(objFS.GetParentFolderName(WScript.ScriptFullName), strLog)
        Set objFile = objFS.CreateTextFile(strLog, True)
        objFile.WriteLine "Обнаружено записей: " & intCounter & vbNewLine & "==="
        objFile.WriteLine strList
        objFile.Close
        Set objFile = Nothing
        Set objFS = Nothing
        Set objWShell = CreateObject("WScript.Shell")
        objWShell.Run "notepad.exe " & strLog, 1
        Set objWShell = Nothing
    Else
        WScript.Echo "Для заданного критерия ничего не обнаружено."
    End If
Else
    WScript.Echo "Ничего не обнаружено."
End If
Set objRSet = Nothing
Set objCommand = Nothing
objConnection.Close
Set objConnection = Nothing
WScript.Quit 0