Soru toplu ping atma

[incsoft]

Arkadaşlar işyerimde bulunan 50 adet bilgisayarıma excel üzerinden ping atmak istiyorum. Bununla ilgili bazı yerlerden dosyalar buldum ancak çalışmıyor. Mesela 50 satırım var ve her birinde IP adresleri mevcut. 192.168.90.12 ...... şeklinde adresler var. Ping at dediğimde online - offline şeklinde yazan bir dosya varmı hazır? Ya da nasıl yapılabilir?

 

[Greenblacksea53]

Sub PingIPAddresses()
    Dim ws As Worksheet
    Dim SonSatır As Long
    Dim i As Long
    
  
    Set ws = ThisWorkbook.Sheets("sayfa1")
    
 
    SonSatır = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
  
    For i = 2 To SonSatır
        If Not IsEmpty(ws.Cells(i, 1).Value) Then
            ws.Cells(i, 2).Value = PingResult(ws.Cells(i, 1).Value)
        End If
    Next i
End Sub

Function PingResult(IPAdres As String) As String
    Dim oShell As Object
    Dim oExec As Object
    Dim oOutput As Object
    Dim sOutput As String
    
 
    Set oShell = CreateObject("WScript.Shell")
    
  
    Set oExec = oShell.Exec("ping -n 1 -w 1000 " & IPAdres)
    Set oOutput = oExec.StdOut
    sOutput = oOutput.ReadAll
    
  
    If InStr(sOutput, "TTL=") > 0 Then
        PingResult = "Online"
    Else
        PingResult = "Offline"
    End If
End Function

Sayfa1 A sütünü baz alındı

 

[incsoft]

Sub PingIPAddresses()
    Dim ws As Worksheet
    Dim SonSatır As Long
    Dim i As Long
   
 
    Set ws = ThisWorkbook.Sheets("sayfa1")
   

    SonSatır = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
 
    For i = 2 To SonSatır
        If Not IsEmpty(ws.Cells(i, 1).Value) Then
            ws.Cells(i, 2).Value = PingResult(ws.Cells(i, 1).Value)
        End If
    Next i
End Sub

Function PingResult(IPAdres As String) As String
    Dim oShell As Object
    Dim oExec As Object
    Dim oOutput As Object
    Dim sOutput As String
   

    Set oShell = CreateObject("WScript.Shell")
   
 
    Set oExec = oShell.Exec("ping -n 1 -w 1000 " & IPAdres)
    Set oOutput = oExec.StdOut
    sOutput = oOutput.ReadAll
   
 
    If InStr(sOutput, "TTL=") > 0 Then
        PingResult = "Online"
    Else
        PingResult = "Offline"
    End If
End Function

Sayfa1 A sütünü baz alındı

Öncelikle teşekkürler. Sonuç alamadım hocam

 

[Greenblacksea53]

Öncelikle teşekkürler. Sonuç alamadım hocam

Kendine göre uyarladın mı Sayfa 1 bende hata vermedi İp adresler Sayfa 1 a1 sütününda başlıyor ping durumunu b sütününa yazıyor, ne hatası verdi mödüle ekleyip mödülü çalışırtırın

 

[incsoft]

Kendine göre uyarladın mı Sayfa 1 bende hata vermedi İp adresler Sayfa 1 a1 sütününda başlıyor ping durumunu b sütününa yazıyor, ne hatası verdi mödüle ekleyip mödülü çalışırtırınEkli dosyayı görüntüle 245898

/QUOTE]

Hiçbir veri gelmiyor. Dosya ektedir

 

[Haluk]

For i=1 to .....


.

 

[incsoft]

For i=1 to .....


.

Oldu Haluk bey ancak cmd ekranı her seferinde açılıp kapanması olmasa iyi olurdu. Teşekkürler.

 

[Haluk]

O zaman WMI kullanılan aşağıdaki kodu deneyin;

Sub Test()
'   Haluk - 08/08/2023

    Dim objPing As Object, objStatus As Object, xRng As Range, strResult As String
    
    For Each xRng In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("Select * from Win32_PingStatus Where Address = '" & xRng & "'")
            
        For Each objStatus In objPing
            xRng.Offset(0, 1) = IIf(objStatus.StatusCode = 0, "Online", "Offline")
         Next
    Next
End Sub

.