It might not be up to the correct standards but it works for me and i wanted to save it here for future reference.
The script can be added to a single module.
'AKA known as QuickPing
Sub WorksheetPing()
Dim MySheet As Worksheet
Dim strColumn
Dim intRow
Dim strComputer
Dim strMACAddress
Dim cell As Range
Dim rNa As Range
Dim FindIt As String
Dim strAddy As String
Dim strColumn1
Set MySheet = Application.ActiveSheet
YesNo = MsgBox("Shall i PING all addresses?", vbYesNo + vbInformation, "PING all addresses on Sheet?")
Select Case YesNo
Case vbYes
On Error GoTo Errormessage
'Ask which column the IP or Hostname resides
strColumn = InputBox("Which letter column do you want to ping?", "Machines column")
Columns(strColumn).Offset(0, 1).Select
Selection.Insert Shift:=xlToRight
'Replace(ActiveCell.Address(0, 0), ActiveCell.Row, "")
strColumn1 = Replace(ActiveCell.Address(0, 0), ActiveCell.Row, "")
Range("A1").Activate
'Ping the IP Addresses
For intRow = 1 To Cells(65536, strColumn).End(xlUp).Row
Cells(intRow, Asc(UCase(strColumn)) - 63).Value = GetPingInfo(Cells(intRow, strColumn).Value)
Next
Case vbNo
Exit Sub
End Select
YesNo = MsgBox("Do you want the Mac-Addresses?", vbYesNo + vbInformation, "Mac-Addresses can be obtained")
Select Case YesNo
Case vbYes
Application.ScreenUpdating = False
'Change Failures to Red Font and then move them over temporarily
On Error Resume Next
FindIt = "Failure"
Set rNa = ActiveSheet.UsedRange.Find(What:=FindIt, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not rNa Is Nothing Then
strAddy = rNa.Address
Do
rNa.Font.ColorIndex = 3
rNa.Offset(0, -1).Copy
rNa.Offset(0, 0).PasteSpecial xlPasteValuesAndNumberFormats
rNa.Offset(0, -1).clear
Set rNa = ActiveSheet.UsedRange.FindNext(rNa)
Loop While rNa.Address <> strAddy
End If
'Get the Mac-Address
Columns(strColumn).Offset(0, 2).Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
For intRow = 1 To Cells(65536, strColumn).End(xlUp).Row
Cells(intRow, Asc(UCase(strColumn)) - 62).Value = Get_MAC_Address(Cells(intRow, strColumn).Value)
Next
'For Each Cell In Range(Whichever Column was chosen)
Columns(strColumn1).Select
For Each cell In Selection
If cell.Font.ColorIndex = 3 Then
cell.Copy
cell.Offset(0, -1).PasteSpecial xlPasteValuesAndNumberFormats
cell.Value = "Failure"
cell.Font.ColorIndex = 1
cell.Offset(1, 0).Activate
End If
Next
'Fit all columns
Cells.EntireColumn.AutoFit
Range("A1").Activate
'Deselect the last cell and hide the Display Status Bar
Application.CutCopyMode = False
Application.StatusBar = ""
Application.DisplayStatusBar = False
Application.ScreenUpdating = True
Case vbNo
End Select
Errormessage:
End Sub
Function GetPingInfo(strComputer)
Dim objShell, boolCode
Set objShell = CreateObject("WScript.Shell")
boolCode = objShell.Run("Ping -n 1 -w 300 " & strComputer, 0, True)
If boolCode = 0 Then
GetPingInfo = "Successful Reply"
Else
GetPingInfo = "Failure"
End If
End Function
Function Get_MAC_Address(strComputer)
Set objShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
objFSO.DeleteFile "c:\MAC.txt", True
On Error GoTo 0
Application.DisplayStatusBar = True
Application.StatusBar = "Getting MAC for " & strComputer & "..."
DoEvents
objShell.Run "cmd /c NBTSTAT -a " & strComputer & " | FIND ""MAC Address"" > C:\MAC.txt", 0, True
Set objMACFile = objFSO.OpenTextFile("C:\MAC.txt", 1, False)
While Not objMACFile.AtEndOfStream
strLine = objMACFile.ReadLine
If Len(strLine) > 35 Then
strMAC = Mid(strLine, 19, 17)
End If
Wend
objMACFile.Close
Set objMACFile = Nothing
Set objShell = Nothing
Set objFSO = Nothing
Get_MAC_Address = strMAC
End Function
No comments:
Post a Comment