Arkadaşlar merhaba,
Benim vba üzerinden oluşturduğum bi macro var macrom çok güzel bi şekilde istediğim gibi çalışıyor buraya kadar sorunum yok fakat yapmak istediğim bi durum var çok araştırdım fakat bulamadım, örnek; makroyu otomatik olarak tüm alanları seçip 10 dk sonra otomatik çalıştırmasını istiyorum böyle bişey vba üzerinden mümkün müdür ? ilgili görsel ve kodları bilginize sunarım.
Çalışma prensibi: bir sutunu seçip butona tıkladığınızda belirlemiş ip üzerinden o sunucuya ping atıyor eğer pingten cevap alırsa yeşil alamazsa kapalı diye kırmızı şekile dönüyor.
Benim vba üzerinden oluşturduğum bi macro var macrom çok güzel bi şekilde istediğim gibi çalışıyor buraya kadar sorunum yok fakat yapmak istediğim bi durum var çok araştırdım fakat bulamadım, örnek; makroyu otomatik olarak tüm alanları seçip 10 dk sonra otomatik çalıştırmasını istiyorum böyle bişey vba üzerinden mümkün müdür ? ilgili görsel ve kodları bilginize sunarım.
Çalışma prensibi: bir sutunu seçip butona tıkladığınızda belirlemiş ip üzerinden o sunucuya ping atıyor eğer pingten cevap alırsa yeşil alamazsa kapalı diye kırmızı şekile dönüyor.
Kod:
Sub GetIPStatus()
Dim Cell As Range
Dim ipRng As Range
Dim result As String, IPString As String
Dim IPSplit As Variant, IPSplit2 As Variant
Dim rngArea As Range
Dim arr() As String
On Error GoTo check
IPSplit = Split(Replace(Range("B2"), " ", " "), ".")
If Application.WorksheetFunction.CountA(IPSplit) > 2 Then
IPString = Trim(Right(IPSplit(0), 3)) & "." & IPSplit(1) & "." & IPSplit(2) & "."
End If
For Each rngArea In Selection
With rngArea
'check does cell has hyperlink
If .Hyperlinks.Count > 0 Then
result = IsConnectible(.Value, 2, 4)
If result Then
.Interior.Color = RGB(0, 255, 0)
Else
.Interior.Color = RGB(255, 0, 0)
End If
GoTo NextIteration:
End If
If InStr(.Value, ".") > 0 Then
If Len(.Value) - Len(Replace(.Value, ".", "")) = 3 Then 'if has 3 points like 192.168.1.2
IPSplit2 = Split(rngArea, ".")
If IsNumeric(IPSplit2(0) + IPSplit2(1) + IPSplit2(2) + IPSplit2(3)) Then
.Interior.ColorIndex = -4142
If Application.WorksheetFunction.Max(IPSplit2(0), IPSplit2(1), IPSplit2(2), IPSplit2(3)) < 256 And Application.WorksheetFunction.Min(IPSplit2(0), IPSplit2(1), IPSplit2(2), IPSplit2(3)) >= 0 Then
result = IsConnectible(.Value, 1, 4)
Debug.Print result
If result Then
.Interior.Color = RGB(0, 255, 0)
Else
.Interior.Color = RGB(255, 0, 0)
End If
End If
GoTo NextIteration:
End If
End If
ElseIf InStr(.Value, ":") > 0 Then
result = IsConnectible(.Value, 2, 6)
If result Then
.Interior.Color = RGB(0, 255, 0)
Else
.Interior.Color = RGB(255, 0, 0)
End If
GoTo NextIteration:
ElseIf IsNumeric(.Value) And rngArea <> "" Then ' if it's number and if it's not blank
.Interior.ColorIndex = -4142
If Len(Range("B2")) - Len(Replace(Range("B2"), ".", "")) > 2 Then
If .Value = Int(.Value) And .Value < 256 And .Value >= 0 And .Offset(, 1).Font.Bold = False And .Offset(, 1).Value <> "broadcast" Then 'If cell is integer and cell on the right is not bold or broadcast
result = IsConnectible(IPString & .Value, 1, 4)
If result = "True" Then
.Interior.Color = RGB(0, 255, 0)
Else
.Interior.Color = RGB(255, 0, 0)
End If
GoTo NextIteration:
End If
ElseIf Len(Range("B2")) - Len(Replace(Range("B2"), ":", "")) > 2 Then
result = IsConnectible(Range("B2") & rngArea, 2, 6)
If result = "True" Then
.Interior.Color = RGB(0, 255, 0)
Else
.Interior.Color = RGB(255, 0, 0)
End If
GoTo NextIteration:
End If
End If
End With
NextIteration:
Next rngArea
Exit Sub
check:
MsgBox "Hata! Lütfen doğru ip seçiniz !'"
End Sub
Function IsConnectible(sHost, iPings, iPv)
Dim nRes
If iPings = "" Then iPings = 2 ' default number of pings
With CreateObject("WScript.Shell")
nRes = .Run("%comspec% /c ping.exe -" & iPv & " -n " & iPings & " " & sHost & " | findstr ""TTL="" > nul 2>&1", 0, True)
' . is a wildcard
' it will search for string within Lost = n (xy% loss) but not (100% loss)
End With
IsConnectible = (nRes = 0)
End Function