Ağda Bilgisayar Kontrolü

[Recep İpek]

Merhaba,

Ağdaki IP numarasını veya adını bildiğimiz bir bilgisayarın açık olup olmadığını nasıl kontrol edebiliriz?

 

[Ali]

Merhaba,

Ağdaki IP numarasını veya adını bildiğimiz bir bilgisayarın açık olup olmadığını nasıl kontrol edebiliriz?

Sn Ripek şöyle bir durum var, Ping komutu ile o bilgisayara bir paket gönderir ve alırsanız o bilgisayar halahazırda ağda ve açık olduğu gösterir ama bu ağ içinde olduğunun göstergesidir. Ağ kablosu çıkarılmışsa ve bilgisayarda açıksa siz sadece onun ağda olmadığı görürsünüz oysa o bilgisayar açıktır.

 

[Recep İpek]

Normalde karşıdaki bilgisayar devamlı ağa bağlı.
Bende sadece o an bilgisayarın açık olup olmadığını bulmak istiyorum.

Aslında asıl hedefim ADO ile bu bilgisayara bağlanırken "Bağlanmak istediğiniz bilgisayar kapalı" şeklinde mesaj yazdırmaya çalışmak.

Birde VBA ile nasıl ping atabiliriz?

 

[Haluk]

.....
...
Birde VBA ile nasıl ping atabiliriz?

http://www.excel.web.tr/showthread.php?t=7291

 

[Recep İpek]

Teşekkürler.

Gözümden kaçmış.

 

[Levent Menteşoğlu]

............Aslında asıl hedefim ADO ile bu bilgisayara bağlanırken "Bağlanmak istediğiniz bilgisayar kapalı" şeklinde mesaj yazdırmaya çalışmak......

Alternatif olarak hata kodundan faydalanabilirsiniz. Yani on error goto .... komutu ile veri çekilemeyince ortaya çıkan hatayı pcnin kapalı olduğunu ifade edecek bir kodlamaya çevirebilirsiniz.

 

[Recep İpek]

Sizin dediğiniz gibi de oluyor.Fakat burada bekleme süresi biraz uzun.

Artık bununla yetineceğiz.

İlgilenenlere teşekkürler.

 

[Haluk]

Bir de aşağıdakini deneyin, tabii kodlarda kırmızı ile işaretlenmiş yere çalışmanızda bağlanmak istediğiniz bilgisayar adını yazdıktan sonra ....

'Kaynak: http://www.freevbcode.com/ShowCode.Asp?ID=5983

Public Const NERR_Success = 0&
Public Const NERR_MoreData = 234&

Public Const SRV_TYPE_ALL = &HFFFF

Private Type SERVER_INFO_API
    PlatformId As Long
    ServerName As Long
    Type As Long
    VerMajor As Long
    VerMinor As Long
    Comment As Long
End Type

Type ServerInfo
    PlatformId As Long
    ServerName As String
    Type As Long
    VerMajor As Long
    VerMinor As Long
    Comment As String
    Platform As String
    ServerType As Integer
    LanGroup As String
    LanRoot As String
End Type

Type ListOfServer
    Init As Boolean
    LastErr As Long
    List() As ServerInfo
End Type

Public Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
        (pTo As Any, _
         uFrom As Any, _
         ByVal lSize As Long)

Declare Function lstrlenW Lib "kernel32" _
        (ByVal lpString As Long) As Long

Declare Function NetApiBufferFree Lib "netapi32" _
        (ByVal lBuffer&) As Long

Declare Function NetGetDCName Lib "netapi32" _
        (lpServer As Any, lpDomain As Any, _
         vBuffer As Any) As Long

Declare Function NetServerEnum Lib "netapi32" _
        (lpServer As Any, ByVal lLevel As Long, vBuffer As Any, _
         lPreferedMaxLen As Long, lEntriesRead As Long, lTotalEntries As Long, _
         ByVal lServerType As Long, ByVal sDomain$, vResume As Any) As Long

Public Const MyServer As String = "[COLOR=Red][B]raider[/B][/COLOR]"

Sub CheckComputer()
    Dim intIDX As Integer
    Dim ServerList As ListOfServer
    Dim MyMsg As String
    ServerList = EnumServer(SRV_TYPE_ALL)
    If ServerList.Init Then
        For i = LBound(ServerList.List) To UBound(ServerList.List)
            If LCase(ServerList.List(i).ServerName) = LCase(MyServer) Then
                MyMsg = "Bilgisayar açık, işleme devam edebilirsiniz...."
                Exit For
            Else
                MyMsg = "Bilgisayar şu anda kapalı veya yanlış bilgisayar adı, daha sonra deneyin...."
            End If
        Next
        MsgBox MyMsg
    End If
End Sub
'
Public Function EnumServer(lServerType As Long) As ListOfServer
    Dim nRet As Long, x As Integer, i As Integer
    Dim lRetCode As Long
    Dim tServerInfo As SERVER_INFO_API
    Dim lServerInfo As Long
    Dim lServerInfoPtr As Long
    Dim ServerInfo As ServerInfo
    Dim lPreferedMaxLen As Long
    Dim lEntriesRead As Long
    Dim lTotalEntries As Long
    Dim sDomain As String
    Dim vResume As Variant
    Dim yServer() As Byte
    Dim SrvList As ListOfServer
    
    yServer = MakeServerName(ByVal "")
    lPreferedMaxLen = 65536
    
    nRet = NERR_MoreData
    Do While (nRet = NERR_MoreData)
        
        'Call NetServerEnum to get a list of Servers
        nRet = NetServerEnum(yServer(0), 101, lServerInfo, _
                             lPreferedMaxLen, lEntriesRead, _
                             lTotalEntries, lServerType, _
                             sDomain, vResume)
        
        If (nRet <> NERR_Success And _
             nRet <> NERR_MoreData) Then
            SrvList.Init = False
            SrvList.LastErr = nRet
            NetError nRet
            Exit Do
        End If
        
        ' NetServerEnum Index is 1 based
        x = 1
        lServerInfoPtr = lServerInfo
        
        Do While x <= lTotalEntries
            
            CopyMem tServerInfo, ByVal lServerInfoPtr, Len(tServerInfo)
            
            ServerInfo.Comment = PointerToStringW(tServerInfo.Comment)
            ServerInfo.ServerName = PointerToStringW(tServerInfo.ServerName)
            ServerInfo.Type = tServerInfo.Type
            ServerInfo.PlatformId = tServerInfo.PlatformId
            ServerInfo.VerMajor = tServerInfo.VerMajor
            ServerInfo.VerMinor = tServerInfo.VerMinor
            
            i = i + 1
            ReDim Preserve SrvList.List(1 To i) As ServerInfo
            SrvList.List(i) = ServerInfo
            
            x = x + 1
            lServerInfoPtr = lServerInfoPtr + Len(tServerInfo)
            
        Loop
        
        lRetCode = NetApiBufferFree(lServerInfo)
        SrvList.Init = (x > 1)
        
    Loop
    
    EnumServer = SrvList
    
End Function

Public Function MakeServerName(ByVal ServerName As String)
    Dim yServer() As Byte

    If ServerName <> "" Then
        If InStr(1, ServerName, "\\") = 0 Then
            ServerName = "\\" & ServerName
        End If
    End If

    yServer = ServerName & vbNullChar
    MakeServerName = yServer

End Function

Public Function NetError(nErr As Long, Optional Ret) As String
    Dim Msg As String

    If IsMissing(Ret) Then Ret = False

    Select Case nErr
        Case 5
            Msg = "Access Denied!"
        Case 1722
            Msg = "Server not accessible!"
        Case 1326
            Msg = " Sie besitzen nicht die Berechtigungen dafür"
        Case Else
            Msg = "Error Nr. (" & nErr & ") !"
    End Select

    If Not Ret Then
        Beep
        MsgBox Msg, vbCritical, "Net Error"
    Else
        NetError = Msg
    End If

End Function
'

Public Function PointerToStringW(lpStringW As Long) As String
    Dim buffer() As Byte
    Dim nLen As Long

    If lpStringW Then
        nLen = lstrlenW(lpStringW) * 2
        If nLen Then
            ReDim buffer(0 To (nLen - 1)) As Byte
            CopyMem buffer(0), ByVal lpStringW, nLen
            PointerToStringW = buffer
        End If
    End If
End Function
'

 

[Recep İpek]

İşte bu......

Süper.....

Kodlar biraz uzun ama işe yarıyor..