|
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
|
|