Option Explicit

Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_FLAG_RELOAD = &H80000000

Private Const mc_USER_AGENT = "Gecko based"

Private Declare Function InternetOpen Lib "wininet" Alias _
      "InternetOpenA" (ByVal sAgent As String, _
      ByVal lAccessType As Long, ByVal sProxyName As String, _
      ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet" _
      (ByRef hInet As Long) As Long

Private Declare Function InternetReadFile Lib "wininet" _
      (ByVal hFile As Long, ByVal sBuffer As String, _
      ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) _
      As Integer

Private Declare Function InternetOpenUrl Lib "wininet" Alias _
      "InternetOpenUrlA" (ByVal hInternetSession As Long, _
      ByVal lpszUrl As String, ByVal lpszHeaders As String, _
      ByVal dwHeadersLength As Long, ByVal dwFlags As Long, _
      ByVal dwContext As Long) As Long

Private Declare Function URLDownloadToFile Lib "urlmon.dll" _
      Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
      ByVal szURL As String, ByVal szFileName As String, _
      ByVal Reserved As Long, ByVal fnCB As Long) As Long

Private Declare Function GetVersionEx Lib "kernel32" Alias _
      "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) _
      As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Public Enum eOIPService
  Germany = 0
  America = 1
  Germany2 = 2
End Enum

Public Property Get IP( _
      Optional ByVal UsedService As eOIPService = 1, _
      Optional strTempFile As String = "C:\IP.TXT") As String

  Dim strUrlIP  As String
  Dim strLeft   As String, strRight As String
  Dim strBuffer As String
  Dim hOpen     As Long, hFile As Long
  Dim nRetVal   As Long
  Dim strRes    As String
  Dim lngLeft   As Long, lngRight As Long
  Dim strWebsource As String
  Dim iFN       As Integer

  On Error GoTo IP_Error

  Select Case UsedService
    Case Is = eOIPService.Germany
      strUrlIP = "http://www.wasistmeineip.de/"
      strLeft = "CopyToClipboard('"
      strRight = "');"
    Case Is = eOIPService.Germany2
      strUrlIP = "http://www.showmyip.de/"
      strLeft = "<br>REMOTE HOST: "
      strRight = vbLf & "<br>PRO"
    Case Else
      strLeft = "<h1>Your IP is "
      strRight = " <br></h1>"
      strUrlIP = "http://www.whatismyip.com/"
  End Select

  If IsWinNT Then
    hOpen = InternetOpen(mc_USER_AGENT, _
          INTERNET_OPEN_TYPE_DIRECT, vbNullString, _
          vbNullString, 0)
    If hOpen <> 0 Then
      hFile = InternetOpenUrl(hOpen, strUrlIP, vbNullString, _
            ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
      If hFile <> 0 Then
        strBuffer = Space$(1000)
        nRetVal = 1
        While nRetVal > 0
          InternetReadFile hFile, strBuffer, 1000, nRetVal
          strWebsource = strWebsource & Trim$(strBuffer)
          strBuffer = Space$(1000)
        Wend
      Else
        strRes = "Fehler beim Zugriff auf die Web-Seite"
      End If
    Else
      strRes = "Fehler bei INet-Verbindung"
    End If
    InternetCloseHandle hFile
    InternetCloseHandle hOpen

  Else
    nRetVal = URLDownloadToFile(0, strUrlIP, strTempFile, 0, 0)
    If nRetVal = 0 Then
      If FileExists(strTempFile) Then
        iFN = FreeFile
        Open strTempFile For Input As #iFN
        strWebsource = Input(LOF(iFN), 1)
        Close #iFN
        Kill strTempFile
      Else
        strRes = "Temporäre Datei konnte nicht angelegt werden"
      End If
    Else
      strRes = "Fehler beim Zugriff auf die Web-Seite"
    End If
  End If

  If LenB(strWebsource) > 0 Then
    lngLeft = InStr(1, strWebsource, strLeft)
    lngRight = InStr(1, strWebsource, strRight)

    If (lngLeft > 0) And (lngRight > 0) Then
      strWebsource = Mid$(strWebsource, lngLeft + Len(strLeft))
      lngRight = InStr(1, strWebsource, strRight)
      strWebsource = Left$(strWebsource, lngRight - 1)
      strRes = Trim$(strWebsource)
    Else
      strRes = "Fehler beim Auslesen der IP"
    End If
  End If

  IP = strRes

  On Error GoTo 0
  Exit Property

IP_Error:
  MsgBox "Fehler " & Err.Number & vbCrLf & Err.Description
End Property

Private Function FileExists(File As String) As Boolean
  On Error Resume Next
  FileExists = False
  FileExists = Dir(File) <> ""
  On Error GoTo 0
End Function

Private Function IsWinNT() As Boolean
  Dim osvi As OSVERSIONINFO

  On Error Resume Next
  osvi.dwOSVersionInfoSize = 148
  osvi.szCSDVersion = Space$(128)
  GetVersionEx osvi
  If osvi.dwMajorVersion > 4 Then IsWinNT = True
  On Error GoTo 0
End Function

Option Explicit

Private Sub cmdReadIP_Click()
  Dim mIP As COnlineIP

  Set mIP = New COnlineIP

  txtIP.Text = "- Bitte warten -"
  txtIP.Text = mIP.IP(cboIPService.ItemData( _
        cboIPService.ListIndex))

  Set mIP = Nothing
End Sub

Private Sub Form_Load()
  With Me.cboIPService
    .Clear
    .AddItem "WasIstMeineIP.de"
    .ItemData(.NewIndex) = 0
    .AddItem "WhatIsMyIP.com"
    .ItemData(.NewIndex) = 1
    .AddItem "ShowMyIP.com"
    .ItemData(.NewIndex) = 2

    .ListIndex = 0
  End With
End Sub