Option Explicit
 
' zunächst alle benötigten API-Deklarationen
Private Declare Function GetTcpTable Lib "iphlpapi.dll" ( _
  ByRef pTcpTable As Any, _
  ByRef pdwSize As Long, _
  ByVal bOrder As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias _
  "RtlMoveMemory" ( _
  dst As Any, _
  src As Any, _
  ByVal bcount As Long)
 
Private Declare Function lstrcpyA Lib "kernel32" _
  (ByVal RetVal As String, ByVal Ptr As Long) As Long
 
Private Declare Function lstrlenA Lib "kernel32" _
  (ByVal Ptr As Any) As Long
 
Private Declare Function inet_ntoa Lib "wsock32.dll" _
  (ByVal addr As Long) As Long
 
Private Type MIB_TCPROW
  dwState As Long
  dwLocalAddr As Long
  dwLocalPort As Long
  dwRemoteAddr As Long
  dwRemotePort As Long
End Type
 
Private Const ERROR_SUCCESS            As Long = 0
Private Const MIB_TCP_STATE_CLOSED     As Long = 1
Private Const MIB_TCP_STATE_LISTEN     As Long = 2
Private Const MIB_TCP_STATE_SYN_SENT   As Long = 3
Private Const MIB_TCP_STATE_SYN_RCVD   As Long = 4
Private Const MIB_TCP_STATE_ESTAB      As Long = 5
Private Const MIB_TCP_STATE_FIN_WAIT1  As Long = 6
Private Const MIB_TCP_STATE_FIN_WAIT2  As Long = 7
Private Const MIB_TCP_STATE_CLOSE_WAIT As Long = 8
Private Const MIB_TCP_STATE_CLOSING    As Long = 9
Private Const MIB_TCP_STATE_LAST_ACK   As Long = 10
Private Const MIB_TCP_STATE_TIME_WAIT  As Long = 11
Private Const MIB_TCP_STATE_DELETE_TCB As Long = 12
' Hilfsfunktionen
Private Function GetString(ByVal lpszA As Long) As String
  GetString = String$(lstrlenA(ByVal lpszA), 0)
  Call lstrcpyA(ByVal GetString, ByVal lpszA)
End Function
 
Private Function GetInetAddrStr(Adresse As Long) As String
  GetInetAddrStr = GetString(inet_ntoa(Adresse))
End Function
' alle IP-Adressen ermitteln
Public Function GetIPAdresses() As String
  Dim TcpRow As MIB_TCPROW
  Dim byBuffer() As Byte
  Dim lBenoetigt As Long
  Dim lGroesse As Long
  Dim lZeilen As Long
  Dim lZaehler As Long
  Dim sAktAdresse As String
  Dim sGefunden() As String
  Dim lAnzahl As Long
  Dim i As Long
  Dim bFound As Boolean
 
  Call GetTcpTable(ByVal 0&, lBenoetigt, 1)
 
  GetIPAdresses = ""
  lAnzahl = 0
 
  If lBenoetigt > 0 Then
    ReDim Buffer(0 To lBenoetigt - 1) As Byte
    If GetTcpTable(Buffer(0), lBenoetigt, 1) = ERROR_SUCCESS Then
      lGroesse = LenB(TcpRow)
      ' Die ersten 4 Bytes enthalten die Anzahl der
      ' Einträge
      CopyMemory lZeilen, Buffer(0), 4
 
      For lZaehler = 1 To lZeilen
        bFound = False
        ' Überspringt die ersten vier Bytes von vorher
        ' und holt die Daten in die TcpRow-Struktur
        CopyMemory TcpRow, Buffer(4 + _
          (lZaehler - 1) * lGroesse), lGroesse
 
        With TcpRow
          sAktAdresse = GetInetAddrStr(.dwLocalAddr)
 
          ' Die IP's können mehrfach vorkommen, deswegen
          ' hier schauen welche IP's schon vorher
          ' gefunden wurden
          For i = 1 To lAnzahl
            bFound = (sAktAdresse = sGefunden(i))
          Next i
 
          If Not bFound And Left(sAktAdresse, 1) <> "0" _
            And sAktAdresse <> "127.0.0.1" Then
 
            GetIPAdresses = GetIPAdresses & _
              GetInetAddrStr(.dwLocalAddr) & ","
            lAnzahl = lAnzahl + 1
 
            ReDim Preserve sGefunden(lAnzahl)
            sGefunden(lAnzahl) = sAktAdresse
          End If
        End With
      Next lZaehler
 
      ' Am Ende das letzte Komma entfernen
      GetIPAdresses = Left(GetIPAdresses, _
        Len(GetIPAdresses) - 1)
    Else
      MsgBox "Es trat ein Fehler beim Füllen der " & _
        "TCP-Struktur auf!"
    End If
  End If
End Function
 
Private Sub Command1_Click()
MsgBox "Meine eigene IP: " & Winsock1.LocalIP
End Sub

-.-