' Alan dot Kaplan at VA dot gov
' DomainSQLServerReport.vbs
' Previous AK version MySQLServers.vbs
' original 10-21-2005
' 3-29-12 improved ping reply, added SPN, collection of service info, 
' and SQL version and instances, added save as Excel.

' The SQL query and the basics come from querySpn.vbs by Craig Wiand 
' Copyright (c) Microsoft Corporation 2004

Option Explicit     
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")
Dim strComputer, strIP
Dim retval
Dim strServiceMessage, bServiceInstalled
dim strSQLInfo, strInstances
Const adOpenStatic = 3
Const adLockOptimistic = 3
Dim sqlRS: Set sqlRS = CreateObject("ADODB.Recordset")
Dim oConn, oCmd, oRS
Dim strADSPath, strADOQuery
Dim root, logname, strError
dim fso,logfile, appendout
Dim bOnlyServers: bOnlyServers = True 
Dim iSpindex, strSpin
Dim message

message = "This script will list all of the SQL servers based on the SPN registered " & _
"in AD within your domain. SPNs are registered for both free and Enterprise editions of SQL, " & _
"so there will be workstations in the list. Do you want to continue?"
retval = MsgBox(message,vbYesNo + vbQuestion,"Get List of SQL Servers")
If retval = vbNo Then WScript.Quit

message = "Limit the search to Server OS?"
retval = MsgBox(message,VBYesNoCancel+VbQuestion,"Only Servers")
If retval = vbCancel Then WScript.Quit
If retval = vbNo Then bOnlyServers = False 

If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	dim quote, strArgs, i
	quote=chr(34)
	
	For i  = WScript.Arguments.Count -1 to  0 Step -1
		strArgs = WScript.Arguments(i) & Space(1) &  strArgs
	Next
	
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote & space(1) & strArgs, 1, true
    WScript.Quit            	'...and stop running as WScript
End If


Set root = GetObject("LDAP://rootDSE")
strADSPath = root.Get("defaultNamingContext")

logname = root.Get("DNSHostName")
logname = Mid(logname,InStr(logname,".")+1)
logname = "SQL on " & Replace(logname,".","_")& ".xls"
logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\" & logname 

'setup log
Const ForAppend = 8
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(logfile) Then fso.DeleteFile logfile,True

set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
appendout.Writeline "SQL System	SPN	OS	IP	SQL Ver	Instances	Errors"

'--- Set up the connection ---
Set oConn = CreateObject("ADODB.Connection")
Set oCmd = CReateObject("ADODB.Command")
oConn.Provider = "ADsDSOObject"
oConn.Open "ADs Provider"
Set oCmd.ActiveConnection = oConn
oCmd.Properties("Page Size") = 1000

'--- Build the query string ---
strADOQuery = "<LDAP://" & strADSPath & ">;" & "(&(servicePrincipalName=MSSqlSvc*)(objectClass=computer))" &  ";" & _
    "servicePrincipalName,dnsHostName,name,operatingsystem,operatingsystemServicePack,distinguishedName;subtree"

oCmd.CommandText = strADOQuery

'--- Execute the query for the object in the directory ---
Set oRS = oCmd.Execute
If oRS.EOF and oRS.Bof Then
	 MsgBox  "No SQL Servers AD entries found!",vbCritical + vbOKOnly,"Failed"
	 appendout.WriteLine "Query Failed"
	 	Else
		 While Not oRS.Eof
		  If not bOnlyServers Or InStr(1,oRS.Fields("operatingSystem"),"Server",1) Then 
		  	'reset variables
			  strSQLInfo = ""
			  strError = "" 
			  strInstances = ""
			  strComputer =  oRS.Fields("Name")
			  retval = PingReply(strComputer)
			  If retval <>  "Online" Then  
			  	strError = retval 
				strSQLInfo = "N/A"
			  Else
			  	strSQLInfo = GetSQLInfo
			  End If 
	
			  If InStr(oRS.Fields("distinguishedName"),strADSPath) Then 
			   	EchoAndLog strComputer & vbtab & GetSQLSPN(oRS.Fields("servicePrincipalName").value)& vbtab & oRS.Fields("operatingSystem")& _
			   	space(1) & oRS.Fields("operatingSystemServicePack") & vbTab & strIP & _
			   	vbTab & strSQLInfo & vbtab & strInstances & vbTab & strError
			   End If
		Else
			Spin()
		End If 
		   oRS.MoveNext
		 Wend
End If

oRS.Close
oConn.Close
appendout.Close
SaveAsExcel(logfile)

On Error GoTo 0
MsgBox "Done. The logfile, " & logname & " is on your desktop.",vbinformation + vbokonly,"Done"

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

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

	'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}"
	
	Set objScriptExec=wshShell.Exec("ping -n 2 -w 1000 " & strComputer)
	strOut = lcase(objScriptExec.StdOut.Readall)

	If InStr(strOut,"could not find host") Then 
		PingReply = "No Host Record"
		Exit Function
	End If  
	
	'moved from v1
	Set matches = objRE.Execute(strOut)   ' Execute search.

	If Matches.count = 1 Then 
	   For Each Match in Matches   ' Iterate Matches collection.
	     strIP = trim(Match.Value) 'Cleanup
	   Next
	Else
		strIP = ""
	End If 

	If InStr(strOut,"unreachable") Then 
		PingReply = "Unreachable"
		Exit Function 				'new in v2
	End If  

	If InStr(strOut,"timed out") Then 
		PingReply = "Timed Out"
		Exit Function 				'new in v2
	End If  
	
	If  InStr(strOut,"bytes=") = 0 Then 
		PingReply = "Offline"
	Else
		PingReply = "Online"
	End If  
End Function

Function GetSQLInfo()
	CheckService "MSSQLSERVER","SQL"
	If Not bServiceInstalled Then 
		GetSQLInfo = "N/A"
		strError = strServiceMessage
		Exit Function 
	End If 
	Dim oSQLConn
	Dim strsql 	
	Dim atemp, aDBNames, i 
	On Error resume Next
	Set oSQLConn = CreateObject("ADODB.Connection")

	'Connect to SQL Database
	oSQLConn.Open _
	    "Provider = SQLOLEDB;" &_
	    "Data Source =" & strComputer & ";"&_
	    "Initial Catalog=master;" & _
	    "INTEGRATED SECURITY=sspi;"
	
	'Formatted to be readable for your convenience.
	'I am not a TSQL expert, not sure if Case is best way to go, but it works...
	strSQL = "SELECT @@Version"

	sqlRS.Open strSql, oSQLConn, adOpenStatic, adLockOptimistic

	If Err <> 0 Then 
		strError = "Failed to query SQL with error: " & Err.Description
		Exit Function 
	End If 
	
	'WScript.Echo sqlrs.fields(0).value
	atemp = Split (sqlrs.fields(0).value,vbLF)
 	GetSQLInfo = atemp(0)
 	sqlRS.Close
 'Get instances
 	'get list of databases on server.  The sid part gets rid of builtins, I think
	strsql = "select name from sysdatabases where sid <> 0x01" 
	sqlRS.Open strsql, oSQLConn, adOpenStatic, adLockOptimistic
	
	aDBNames = sqlRS.GetRows()
	For i = 0 To ubound(aDBNames,2)
		strInstances = strInstances &  aDBNames(0,i) & "," 
	Next	

	strInstances = Left(strInstances,Len(strInstances)-1)
 	
	sqlRS.Close
	oSQLConn.Close
End Function 

Sub CheckService(strServiceName,strServiceDescription)
	Dim colServices, objService, oWMI
	Dim iServicePresent : iServicePresent = 0
	On Error Resume Next 
	Set oWMI = GetObject("winmgmts:" _	
		& "{impersonationLevel=impersonate}!\\" & strComputer& "\root\cimv2")
	If Err.Number <> 0 Then 
		strServiceMessage =  "WMI Connection Failed. " & Err.Description
		bServiceInstalled = False
		Exit Sub 
	End If 
		
	Set colServices = oWMI.ExecQuery ("SELECT State FROM Win32_Service where name ='" & strServiceName & "'" )
	
	For Each objService in colServices
		iServicePresent = colServices.count
		strServiceMessage =  strServiceDescription & " is " & objService.State & " on " & strComputer
	Next
	
	If iServicePresent = 0 Then 
		strServiceMessage =  strServiceDescription & " is not installed." 
		bServiceInstalled = False
	Else
		bServiceInstalled = True 
	End If 
	On Error goto 0
End Sub 

Function GetSQLSPN(aSPNs)
	Dim i
	For i = 0 To UBound(aSPNs)
		If InStr(1,aSPNS(i),"MSSQLSvc",1) Then 
			GetSQLSPN = aSPNS(i)
			Exit For
		End If 
	Next 
End Function 

Sub EchoAndLog (message)
'Echo output and write to log
	Wscript.Echo message
	AppendOut.WriteLine message
End Sub  
	
Sub SaveAsExcel(strFileName)
	strFileName = LCase(strFileName)
	Const xlnormal = -4143
	Const xlAscending = 1
	Const xlDescending = 2
	Const xlYes = 1
	const xlSortValues = 1

	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
		Dim strNewName: strNewName = Replace(".xls", ".txt")
		fso.MoveFile strFileName, strNewName
		logfile = strNewName
		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
	Set objRange2 = oXL.Range("A2")
	'Set objRange3 = oXL.Range("B2")
	'objRange.Sort objRange2, xlAscending, objRange3, ,xlAscending, , , xlYes
	
	objRange.Sort objRange2, xlAscending,,,,,, xlYes

	objRange.EntireColumn.Autofit()
	
	With oXL.Worksheets(1).Columns("F")
		.ColumnWidth = 42
		.WrapText = True
	End With 
	
	With oXL.Worksheets(1).Columns("G")
		.ColumnWidth = 42
		.WrapText = True
	End With 

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

Sub Spin()
	If iSpinDex >= 4 Then iSpinDex = 0

	Select Case iSpinDex
	Case 0
		strSpin = "\"
	Case 1
		strSpin =  "|"
	Case 2
		strSpin = "/"
	Case 3
		strSpin = "-"
	End Select
	
	WScript.StdOut.Write strSpin
	WScript.Sleep(200)
	WScript.StdOut.Write Chr(8)
	iSpindex = iSpinDex + 1
End Sub 


Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function