hannable80
Technical User
Hi,
I am having a problem with the below code. Basicaly the issue is that the code works fine on a local PC but when i try to use it to change a remote machines.
dim WshShell
dim WshSysEnv
dim Path
dim PathToAdd
set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
' Format the cell A1 and add the text: Service
Set objCOmmand.ActiveConnection = objConnection
objCommand.CommandText = _
"Select Name, Location from 'LDAP://xxxxxx' " _
& "Where objectClass='Computer'"
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRecordSet = objCommand.Execute
objExcel.Workbooks.Add
objExcel.Cells(1, 1).Value = "Ping"
objExcel.Cells(1, 1).Font.Bold = TRUE
objExcel.Cells(1, 1).Interior.ColorIndex = 43
objExcel.Cells(1, 1).Font.ColorIndex = 2
' Format the cell A1 and add the text: Status
objExcel.Cells(1, 2).Value = "Model"
objExcel.Cells(1, 2).Font.Bold = TRUE
objExcel.Cells(1, 2).Interior.ColorIndex = 50
objExcel.Cells(1, 2).Font.ColorIndex = 2
' Format the cell A1 and add the text: Status
objExcel.Cells(1, 3).Value = "Computer"
objExcel.Cells(1, 3).Font.Bold = TRUE
objExcel.Cells(1, 3).Interior.ColorIndex = 49
objExcel.Cells(1, 3).Font.ColorIndex = 2
x = 1
'==================================================================Ping function=====================================================
Function PingStatus(strComputer)
On Error Resume Next
strWorkstation = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strWorkstation & "\root\cimv2")
Set colPings = objWMIService.ExecQuery _
("SELECT * FROM Win32_PingStatus WHERE Address = '" & strComputer & "'")
For Each objPing in colPings
Select Case objPing.StatusCode
Case 0 PingStatus = "Success"
Case 11001 PingStatus = "Status code 11001 - Buffer Too Small"
Case 11002 PingStatus = "Status code 11002 - Destination Net Unreachable"
Case 11003 PingStatus = "Status code 11003 - Destination Host Unreachable"
Case 11004 PingStatus = _
"Status code 11004 - Destination Protocol Unreachable"
Case 11005 PingStatus = "Status code 11005 - Destination Port Unreachable"
Case 11006 PingStatus = "Status code 11006 - No Resources"
Case 11007 PingStatus = "Status code 11007 - Bad Option"
Case 11008 PingStatus = "Status code 11008 - Hardware Error"
Case 11009 PingStatus = "Status code 11009 - Packet Too Big"
Case 11010 PingStatus = "Status code 11010 - Request Timed Out"
Case 11011 PingStatus = "Status code 11011 - Bad Request"
Case 11012 PingStatus = "Status code 11012 - Bad Route"
Case 11013 PingStatus = "Status code 11013 - TimeToLive Expired Transit"
Case 11014 PingStatus = _
"Status code 11014 - TimeToLive Expired Reassembly"
Case 11015 PingStatus = "Status code 11015 - Parameter Problem"
Case 11016 PingStatus = "Status code 11016 - Source Quench"
Case 11017 PingStatus = "Status code 11017 - Option Too Big"
Case 11018 PingStatus = "Status code 11018 - Bad Destination"
Case 11032 PingStatus = "Status code 11032 - Negotiating IPSEC"
Case 11050 PingStatus = "Status code 11050 - General Failure"
Case Else PingStatus = "Status code " & objPing.StatusCode & _
" - Unable to determine cause of failure."
End Select
Next
End Function
'----------------------------------------------------------------------------------------------
'===========================================================Write each service to Excel, starting in A2
Do Until objRecordSet.EOF
' ` services on this computer
on error resume next
strComputer = objRecordSet.Fields("Name").Value
'Sets the compter name
Set colItems = objWMIService.ExecQuery("SELECT * FROM " _
& "Win32_ComputerSystem", "WQL", wbemFlagReturnImmediately _
+ wbemFlagForwardOnly )
Set WshShell1 = CreateObject("WScript.Shell")
' makes environment settings permanent
Set WshSystemUser = WshShell1.Environment("USER")
' Set environment variable
WshSystemUser("Path") = "P:\SAR\Deploy21"
Set WshShell = WScript.CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
Path = WshSysEnv("PATH")
PathToAdd = "P:\SAR\Deploy41"
'MsgBox Path
If Not (InStr(1, Path, PathToAdd & ";") Or Right(Path, Len(PathToAdd)) = PathToAdd) Then 'If it already exists, don't add it again
If Right(Path, 1) <> ";" Then Path = Path & ";" 'check for semi colon at the end
Path = Path & PathToAdd
'MsgBox Path
WshSysEnv.Item("PATH") = Path
End If
For Each objItem in colItems
x = x + 1
strPingStatus = PingStatus(strComputer)
If strPingStatus = "Success" Then
objExcel.Cells(x, 1) = "Success"
objExcel.Cells(x, 2) = objItem.Model
objExcel.Cells(x, 3) = objRecordSet.Fields("Name").Value
end if
NEXT
objRecordSet.MoveNext
loop
I am having a problem with the below code. Basicaly the issue is that the code works fine on a local PC but when i try to use it to change a remote machines.
dim WshShell
dim WshSysEnv
dim Path
dim PathToAdd
set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
' Format the cell A1 and add the text: Service
Set objCOmmand.ActiveConnection = objConnection
objCommand.CommandText = _
"Select Name, Location from 'LDAP://xxxxxx' " _
& "Where objectClass='Computer'"
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRecordSet = objCommand.Execute
objExcel.Workbooks.Add
objExcel.Cells(1, 1).Value = "Ping"
objExcel.Cells(1, 1).Font.Bold = TRUE
objExcel.Cells(1, 1).Interior.ColorIndex = 43
objExcel.Cells(1, 1).Font.ColorIndex = 2
' Format the cell A1 and add the text: Status
objExcel.Cells(1, 2).Value = "Model"
objExcel.Cells(1, 2).Font.Bold = TRUE
objExcel.Cells(1, 2).Interior.ColorIndex = 50
objExcel.Cells(1, 2).Font.ColorIndex = 2
' Format the cell A1 and add the text: Status
objExcel.Cells(1, 3).Value = "Computer"
objExcel.Cells(1, 3).Font.Bold = TRUE
objExcel.Cells(1, 3).Interior.ColorIndex = 49
objExcel.Cells(1, 3).Font.ColorIndex = 2
x = 1
'==================================================================Ping function=====================================================
Function PingStatus(strComputer)
On Error Resume Next
strWorkstation = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strWorkstation & "\root\cimv2")
Set colPings = objWMIService.ExecQuery _
("SELECT * FROM Win32_PingStatus WHERE Address = '" & strComputer & "'")
For Each objPing in colPings
Select Case objPing.StatusCode
Case 0 PingStatus = "Success"
Case 11001 PingStatus = "Status code 11001 - Buffer Too Small"
Case 11002 PingStatus = "Status code 11002 - Destination Net Unreachable"
Case 11003 PingStatus = "Status code 11003 - Destination Host Unreachable"
Case 11004 PingStatus = _
"Status code 11004 - Destination Protocol Unreachable"
Case 11005 PingStatus = "Status code 11005 - Destination Port Unreachable"
Case 11006 PingStatus = "Status code 11006 - No Resources"
Case 11007 PingStatus = "Status code 11007 - Bad Option"
Case 11008 PingStatus = "Status code 11008 - Hardware Error"
Case 11009 PingStatus = "Status code 11009 - Packet Too Big"
Case 11010 PingStatus = "Status code 11010 - Request Timed Out"
Case 11011 PingStatus = "Status code 11011 - Bad Request"
Case 11012 PingStatus = "Status code 11012 - Bad Route"
Case 11013 PingStatus = "Status code 11013 - TimeToLive Expired Transit"
Case 11014 PingStatus = _
"Status code 11014 - TimeToLive Expired Reassembly"
Case 11015 PingStatus = "Status code 11015 - Parameter Problem"
Case 11016 PingStatus = "Status code 11016 - Source Quench"
Case 11017 PingStatus = "Status code 11017 - Option Too Big"
Case 11018 PingStatus = "Status code 11018 - Bad Destination"
Case 11032 PingStatus = "Status code 11032 - Negotiating IPSEC"
Case 11050 PingStatus = "Status code 11050 - General Failure"
Case Else PingStatus = "Status code " & objPing.StatusCode & _
" - Unable to determine cause of failure."
End Select
Next
End Function
'----------------------------------------------------------------------------------------------
'===========================================================Write each service to Excel, starting in A2
Do Until objRecordSet.EOF
' ` services on this computer
on error resume next
strComputer = objRecordSet.Fields("Name").Value
'Sets the compter name
Set colItems = objWMIService.ExecQuery("SELECT * FROM " _
& "Win32_ComputerSystem", "WQL", wbemFlagReturnImmediately _
+ wbemFlagForwardOnly )
Set WshShell1 = CreateObject("WScript.Shell")
' makes environment settings permanent
Set WshSystemUser = WshShell1.Environment("USER")
' Set environment variable
WshSystemUser("Path") = "P:\SAR\Deploy21"
Set WshShell = WScript.CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
Path = WshSysEnv("PATH")
PathToAdd = "P:\SAR\Deploy41"
'MsgBox Path
If Not (InStr(1, Path, PathToAdd & ";") Or Right(Path, Len(PathToAdd)) = PathToAdd) Then 'If it already exists, don't add it again
If Right(Path, 1) <> ";" Then Path = Path & ";" 'check for semi colon at the end
Path = Path & PathToAdd
'MsgBox Path
WshSysEnv.Item("PATH") = Path
End If
For Each objItem in colItems
x = x + 1
strPingStatus = PingStatus(strComputer)
If strPingStatus = "Success" Then
objExcel.Cells(x, 1) = "Success"
objExcel.Cells(x, 2) = objItem.Model
objExcel.Cells(x, 3) = objRecordSet.Fields("Name").Value
end if
NEXT
objRecordSet.MoveNext
loop