Option Explicit

' узнаем имя локального компьютера

Dim ServerName

Dim Network
Set Network = WScript.CreateObject("WScript.Network")
ServerName = Network.ComputerName
Set Network = Nothing

' выбираем RootDSE

Dim RootDSE
Set RootDSE = GetObject("LDAP://" & ServerName & "/RootDSE")
' можно было бы и так:
' Set RootDSE = GetObject("LDAP://RootDSE")
' но так иногда возникают проблемы на Windows NT

' выбираем configurationNamingContext

Dim CNC
CNC = RootDSE.Get("configurationNamingContext")

' открываем коннекцию ADO через ADSI провайдер OLE DB

Dim Connection
Set Connection = CreateObject("ADODB.Connection")
Connection.Provider = "ADsDSOObject"
Connection.Open "ADs Provider"
' кстати, первым параметром метода Open может быть любая
' (в том числе пустая) строка
' традиционно указывается "ADs Provider"

' самое интересное - строка запроса

Dim Query
Query = "<LDAP://" & CNC & _
	">;(objectCategory=msExchExchangeServer);" & _
	"name,serialNumber;subtree"

' исполняем команду

Dim Command
Set Command = CreateObject("ADODB.Command")
Command.ActiveConnection = Connection
Command.CommandText = Query

Dim Recordset
Set Recordset = Command.Execute

' пробегаемся по результатам

Dim S

Do While Not Recordset.EOF
	' версия возвращается почему-то как Variant,
	' т.е. следующая строка не пройдет:
	' S = S & Recordset.Fields("serialNumber") 
	Dim Version
	Version = Recordset.Fields("serialNumber").Value

	' записываем результат
	S = S & Recordset.Fields("name") & " - " & Version(0) & vbNewLine
	Recordset.MoveNext
Loop

' закрываем все, что открыли

Recordset.Close
Connection.Close

Set Recordset = Nothing
Set Command = Nothing
Set Connection = Nothing

' сообщаем результат

If Len(S) = 0 Then
	S = "No Microsoft Exchange servers found!"
Else
	S = "Servers found:"& vbNewLine & S
End If

MsgBox S, vbOkOnly + vbInformation