'Alan dot Kaplan at va dot 10/26/2009
'www.akaplan.com/blog

On Error Resume Next
Dim message, strComputer
Dim objWMIService, colitems, objitem
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")

Const strFeature = "Remote Differential Compression"  ' This is the name of the Windows 2008 feature you are looking for

If WScript.Arguments.Count = 1 Then
	strComputer = WScript.Arguments(0)
Else
	strComputer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
	strComputer = InputBox("Get list of SCCM Distribution Points and BITS status from what parent primary server","Parent Primary",strComputer)
End If 

If strcomputer = "" Then WScript.Quit
strComputer = UCase(strComputer)

Dim fso,logfile, appendout
logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\"  & strcomputer & "_DPs.xls"

'setup log
Const ForAppend = 8
set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(logfile) then fso.DeleteFile logfile

set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
Set locator = CreateObject("WbemScripting.SWbemLocator")
Set wmi = locator.ConnectServer(strComputer, "root\sms")
For Each obj In wmi.InstancesOf("__NAMESPACE")
	If InStr(obj.Name,"site") > 0 Then 
	strNameSpace = "\root\sms\" & obj.Name
	End If 
Next

Set objWMIService = GetObject("winmgmts:\\" & strComputer & strNamespace)
If Err <> 0 Then WScript.Echo Err.Description
Set colItems = objWMIService.ExecQuery("SELECT * FROM SMS_SystemResourceList where RoleName = 'SMS Distribution Point'",,48)

appendout.WriteLine "Site Code	Server Name	Online	FQDN	Resource Type	OS	BITS"

Dim bGetBits, strBits, strServer, strOnline, strOS

For Each objitem In colitems
	bGetBits = False
  	strServer = objitem.ServerRemoteName
    strOnline = "False"
  	strBits = "Unknown"
  	strOS = "Unknown"
  	
	If PingReply(strServer) Then 
	  strOnline = "True"

	  If  objItem.ResourceType = "Windows NT Server" Then 
	  	bGetBits = True
	  Else
	  	strBits = "N/A"
	  End If
	  
	  strOS = PCOS(strServer)
  	End If 
 
  echoandlog objItem.SiteCode & vbTab & objitem.serverName & vbTab & strOnline &vbTab & strServer & vbTab & _
  objItem.ResourceType & vbTab & strOS  & vbTab & strBits
Next


appendout.Close
SaveAsExcel(logfile)


'==== Functions and Subs ===========

Function PCOS(strComputer)
	dim oWMI,ColOS,ObjOS, OSver, colFeatures, objFeature
	Set oWMI = GetObject("winmgmts:\\"& strComputer &"\root\cimv2")
	Set ColOS = oWMI.ExecQuery("SELECT Caption FROM Win32_OperatingSystem")
	
	If Err <> 0 Then 
		PCOS = "Could not determine, " & Err.Description
		Exit Function
	End If 
	
	For Each ObjOS In ColOS
		 PCOS = objOS.caption
	Next
	
	'Thanks to Suzanne Prindiville for this.
	If bGetBits and InStr(PCOS,"Server") Then 
	strBits =  strFeature & " not installed"
	Set colFeatures = oWMI.ExecQuery("SELECT name FROM Win32_ServerFeature WHERE Name = '" & strFeature & "'", , 48) ' Connect to the class
		For Each objFeature In colFeatures ' display the data we requested
			strBits=  strFeature & " installed"
		Next
	End If 
End Function 


Sub EchoAndLog (message)
'Echo output and write to log
	Wscript.Echo message
	AppendOut.WriteLine message
End Sub  

Function PingReply(strcomputer) 
	Dim objScriptExec, strPingResults
	Dim objRE, match, matches

	'RegEx pattern from Bill Stewart
	Set objRE = New RegExp
    objRE.Pattern = " [0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}: "
	
	'Three lines from Steve Cathersalc 
	Set objScriptExec=wshShell.Exec("ping -n 2 -w 1000 " & strComputer)
	Set Matches = objRE.Execute(objScriptExec.StdOut.Readall)   ' Execute search.

	If Matches.count = 1 Then 
	   PingReply = True
	   For Each Match in Matches   ' Iterate Matches collection.
	     strIP = trim(replace(Match.Value,":","")) 'Cleanup
	   Next
	Else
		strIP = ""
		PingReply = False
	End If 
End Function

Sub SaveAsExcel(strFileName)
	Const xlnormal = -4143 
	Dim fso, oXL, objRange
	Set fso = CreateObject("Scripting.FileSystemObject")
	If Not fso.FileExists(strFileName) Then WScript.Quit
	On Error Resume Next
	Set oXL = CreateObject("Excel.Application")
	
	If Err <> 0 Then 'Excel not installed
		Err.Clear
		On Error GoTo 0
		Exit Sub
	End If 
	
	'oXL.Visible = True
	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	objRange.EntireColumn.Autofit()

	Dim oWS	
	Set oWS = oXL.Worksheets(1)
	oWS.Activate
	oWS.Name = sdomain
	
	oXL.ActiveWorkBook.SaveAs strFileName,xlnormal,,,,,,,True 'overwrite existing
	oXL.ActiveWorkBook.Close
	oXL.Quit
	'WScript.Echo "Done"
End Sub