There is a bit more code required than I'd like. If there is a more compact approach I'd be interested myself.
As I understand this, Windows gets the information via UPnP. UPnP works as a sort of Web Service over UDP. It has quirks because it uses UDP multicasts so it can be dificult to code explicitly, but Windows offers a helper library. This library is not "wrapped" well for use from a VB6 program, but with a few tricks you can get access to most of its functionality.
The sample below is written so that it can compile on Win XP as well as later versions of Windows. The Win XP version of the library lacks critical typelib info that prevents VB6 from using everything it offers. This was corrected in Vista, however for this application we don't need the full callback capabilities it offers. You could use an external typelib if you needed full access, or you can compile on Vista or later. A progam compiled on Vista works fine on XP.
The code below is abstracted from a larger Class I use for UPnP NAT port mapping in VB6 servers. This subset may do what you require though.
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
You may have to tweak this some if you have multiple UPnP devices providing connections in your network.