Требуется немного больше кода, чем хотелось бы. Если есть более компактный подход, я был бы заинтересован сам.
Насколько я понимаю, Windows получает информацию через UPnP. UPnP работает как своего рода веб-сервис через UDP. У него есть свои причуды, потому что он использует многоадресную рассылку UDP, поэтому может быть сложно явно кодировать, но Windows предлагает вспомогательную библиотеку. Эта библиотека не очень хорошо «обернута» для использования в программе VB6, но с помощью нескольких приемов вы можете получить доступ к большинству ее функций.
Пример ниже написан так, чтобы он мог компилироваться как в Win XP, так и в более поздних версиях Windows. В версии библиотеки для Win XP отсутствует критическая информация о typelib, которая не позволяет VB6 использовать все, что она предлагает. Это было исправлено в Vista, однако для этого приложения нам не нужны все возможности обратного вызова, которые он предлагает. Вы можете использовать внешнюю библиотеку типов, если вам нужен полный доступ, или вы можете скомпилировать в Vista или более поздней версии. Программа, скомпилированная на Vista, отлично работает на XP.
Приведенный ниже код извлечен из более крупного класса I, используемого для сопоставления портов UPnP NAT на серверах VB6. Это подмножество может делать то, что вам нужно.
UPnPNAT.cls
Option Explicit
'Requires reference to:
'
' UPnP 1.0 Type Library (Control Point)
'
Private Const CONN_SVCTYPEID_URI As String = "urn:schemas-upnp-org:service:WANIPConnection:1"
Private Const CONN_ID_URI As String = "urn:upnp-org:serviceId:WANIPConn1"
Private UDFinder As UPNPLib.UPnPDeviceFinder
Private WithEvents UNCBs As UPnPNATCBs
Private findData As Long
Private blnSuccess As Boolean
Public Event Result(ByVal Success As Boolean, ByVal FriendlyName As String, ByVal IP As String)
Public Sub Fetch()
blnSuccess = False
Set UDFinder = New UPNPLib.UPnPDeviceFinder
Set UNCBs = New UPnPNATCBs
findData = CallByName(UDFinder, "CreateAsyncFind", VbMethod, CONN_SVCTYPEID_URI, 0, UNCBs)
UDFinder.StartAsyncFind findData
End Sub
Private Sub UNCBs_DeviceAdded(ByVal Device As UPNPLib.IUPnPDevice)
Dim Services As UPNPLib.UPnPServices
Dim Service As UPNPLib.UPnPService
Dim varInActionArgs, varOutActionArgs
Dim strFriendlyName As String
Dim strIP As String
strFriendlyName = Device.FriendlyName
On Error Resume Next
Set Services = Device.Services
If Err.Number = 0 Then
On Error GoTo 0
With Services
If .Count > 0 Then
On Error Resume Next
Set Service = .Item(CONN_ID_URI)
If Err.Number = 0 Then
On Error GoTo 0
ReDim varInActionArgs(0 To 0)
ReDim varOutActionArgs(0 To 0)
Service.InvokeAction "GetExternalIPAddress", _
varInActionArgs, _
varOutActionArgs
strIP = varOutActionArgs(0)
blnSuccess = True
Else
On Error GoTo 0
End If
End If
End With
Else
On Error GoTo 0
End If
UDFinder.CancelAsyncFind findData
RaiseEvent Result(blnSuccess, strFriendlyName, strIP)
Set UDFinder = Nothing
Set UNCBs = Nothing
End Sub
Private Sub UNCBs_SearchComplete()
If Not blnSuccess Then
RaiseEvent Result(False, "", "")
End If
End Sub
UPnPNATCBs.cls
Option Explicit
Public Event DeviceAdded(ByVal Device As UPNPLib.IUPnPDevice)
Public Event DeviceRemoved(ByVal UDN As String)
Public Event SearchComplete()
Public Sub IDispatchCallback( _
ByVal pDevice As Variant, _
ByVal bstrUDN As Variant, _
ByVal lType As Variant)
'NOTE: Must be dispID = 0, i.e. the default method of the class.
Select Case lType
Case 0
RaiseEvent DeviceAdded(pDevice)
Case 1
RaiseEvent DeviceRemoved(bstrUDN)
Case 2
RaiseEvent SearchComplete
End Select
End Sub
Form1.frm
Option Explicit
Private WithEvents UN As UPnPNAT
Private Sub Form_Load()
Set UN = New UPnPNAT
lblStatus.Caption = "Searching..."
UN.Fetch
End Sub
Private Sub UN_Result(ByVal Success As Boolean, ByVal FriendlyName As String, ByVal IP As String)
If Success Then
lblStatus.Caption = FriendlyName & " " & IP
Else
lblStatus.Caption = "Failed"
End If
End Sub
Возможно, вам придется настроить это, если у вас есть несколько устройств UPnP, обеспечивающих соединения в вашей сети.