0

うーん...タイトルがすべてだと思います。ネットワーク上に「JOAN-PC」などの PC が存在するかどうかを確認したい。

今、私はこのようなことをしています:

Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
MsgBox Not CBool(oShell.NameSpace(CVar("\\JOAN-PC")) Is Nothing)

うまく機能しますが、遅く、私のプログラムはそれを何度も呼び出す必要があります。同じことをすばやく行う方法を知っている人はいますか?

前もって感謝します。

4

1 に答える 1

0

おそらく、または関連する単純なネットワーク API を使用することもできますNetRemoteTOD。「ping」リクエストを使用することもできます。

適応できる小さな例を次に示します。試してみてください。応答しないマシンのタイムアウトはそれほど長くないようです (7 または 8 秒)。合法的に使用する場合、これはおそらく問題にはなりませんが、被害者のマシンの IP アドレスでネットワーク全体を一掃しようとする悪意のある「スキャナー」を思いとどまらせるには十分です。

Option Explicit

'Fetch and display Net Remote Time Of Day from a
'remote Windows system.  Supply a UNC hostname,
'DNS name, or IP address - or empty string for
'the local host's time and date.
'
'Form has 3 controls:
'
'   txtServer   TextBox
'   cmdGetTime  CommandButton
'   lblTime     Label

Private Const NERR_SUCCESS As Long = 0

Private Type TIME_OF_DAY_INFO
    tod_elapsedt As Long
    tod_msecs As Long
    tod_hours As Long
    tod_mins As Long
    tod_secs As Long
    tod_hunds As Long
    tod_timezone As Long
    tod_tinterval As Long
    tod_day As Long
    tod_month As Long
    tod_year As Long
    tod_weekday As Long
End Type

Private Declare Function NetApiBufferFree Lib "netapi32" ( _
    ByVal lpBuffer As Long) As Long

Private Declare Function NetRemoteTOD Lib "netapi32" ( _
    ByRef UncServerName As Byte, _
    ByRef BufferPtr As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByRef pTo As Any, _
    ByRef uFrom As Any, _
    ByVal lSize As Long)

Private Function GetTOD(ByVal Server As String) As Date
    Dim bytServer() As Byte
    Dim lngBufPtr As Long
    Dim todReturned As TIME_OF_DAY_INFO

    bytServer = Trim$(Server) & vbNullChar
    If NetRemoteTOD(bytServer(0), lngBufPtr) = NERR_SUCCESS Then
        CopyMemory todReturned, ByVal lngBufPtr, LenB(todReturned)
        NetApiBufferFree lngBufPtr
        With todReturned
            GetTOD = DateAdd("n", _
                             -.tod_timezone, _
                             DateSerial(.tod_year, .tod_month, .tod_day) _
                           + TimeSerial(.tod_hours, .tod_mins, .tod_secs))
        End With
    Else
        Err.Raise vbObjectError Or &H2000&, _
                  "GetTOD", _
                  "Failed to obtain time from server"
    End If
End Function

Private Sub cmdGetTime_Click()
    Dim dtServerTime As Date

    On Error Resume Next
    dtServerTime = GetTOD(txtServer.Text)
    If Err.Number <> 0 Then
        lblTime.Caption = Err.Description
    Else
        lblTime.Caption = CStr(dtServerTime)
    End If
    On Error GoTo 0
    txtServer.SetFocus
End Sub
于 2013-01-12T13:26:49.313 に答える