Option Explicit
'一个获得自己外网 IP 地址的程序代码。
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const scUserAgent = "Microsoft Internet Explorer 6.0"
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" 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 InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Function GetWebSoundCode(ByVal URL As String) As String
Dim hOpen As Long
Dim hOpenUrl As Long
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
'调用时 URL 参数一定要带“http://”前缀.
If Left$(LCase$(URL), 7) <> "http://" Then URL = "http://" & URL
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, URL, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
GetWebSoundCode = sBuffer
If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
End Function
Public Function GetIP1() As String
On Error GoTo SoErr
Dim strSoundCode As String, intStrCount As Integer
strSoundCode = GetWebSoundCode("http://web.sunsen.net/")
'没有获取源码跳出函数。
If Len(strSoundCode) < 10 Then Exit Function
'获取 IP 地址。
GetIP1 = Mid$(strSoundCode, InStr(strSoundCode, "您现在的IP是:") + 8)
GetIP1 = Mid$(GetIP1, 1, InStr(GetIP1, "<") - 1)
'获取地理位置。
strSoundCode = Mid$(strSoundCode, InStr(strSoundCode, "欢迎来自") + 4)
strSoundCode = Mid$(strSoundCode, 1, InStr(strSoundCode, "的朋友") - 1)
GetIP1 = GetIP1 & strSoundCode
intStrCount = lstrlen(GetIP1)
If intStrCount < 32 Then
GetIP1 = GetIP1 & String$(32 - intStrCount, Chr$(32))
Else
For intStrCount = 1 To intStrCount
If lstrlen(GetIP1) < 33 Then Exit For
GetIP1 = Mid$(GetIP1, 1, Len(GetIP1) - 1)
Next
End If
Exit Function
SoErr:
'MsgBox "程序运行时发生错误,错误信息如下:" & vbCrLf & _
"=========================================" & vbCrLf & _
"错误号:" & Err.Number & vbCrLf & _
"错误描述:" & Err.Description & vbCrLf & _
"错误源:" & Err.Source & vbCrLf & _
"变量 GetIP1 = " & GetIP1, , "GetIP1 中有错误发生!"
GetIP1 = ""
Exit Function
End Function
Public Function GetIP2() As String
On Error GoTo SoErr
Dim strSoundCode As String, strLineArray() As String, intStrCount As Integer
'获取 IP 地址。
strSoundCode = GetWebSoundCode("http://archive.apnic.net/templates/ipv6man/")
strSoundCode = Mid$(strSoundCode, InStr(strSoundCode, Chr$(39)) + 1)
GetIP2 = Mid$(strSoundCode, 1, InStr(strSoundCode, Chr$(39)) - 1)
'确保获得的是一个 IP 地址。
strLineArray = Split(GetIP2, Chr$(46))
intStrCount = UBound(strLineArray)
If intStrCount < 3 Then Err.Raise 666 '产生一个自定义错误号的错误。
Erase strLineArray '释放数组所用内存。
'获取地理位置。
strSoundCode = GetWebSoundCode("http://submit.apnic.net/cgi-bin/jwhois.pl")
strLineArray = Split(strSoundCode, vbCrLf)
strSoundCode = ""
For intStrCount = 0 To UBound(strLineArray)
If InStr(1, strLineArray(intStrCount), "country:", vbTextCompare) > 0 Then
strSoundCode = strLineArray(intStrCount)
Exit For
End If
Next
GetIP2 = GetIP2 & Chr$(9) & strSoundCode
intStrCount = lstrlen(GetIP2)
If intStrCount < 32 Then
GetIP2 = GetIP2 & String$(32 - intStrCount, Chr$(32))
Else
For intStrCount = 1 To intStrCount
If lstrlen(GetIP2) < 33 Then Exit For
GetIP2 = Mid$(GetIP2, 1, Len(GetIP2) - 1)
Next
End If
Exit Function
SoErr:
'MsgBox "程序运行时发生错误,错误信息如下:" & vbCrLf & _
"=========================================" & vbCrLf & _
"错误号:" & Err.Number & vbCrLf & _
"错误描述:" & Err.Description & vbCrLf & _
"错误源:" & Err.Source & vbCrLf & _
"变量 GetIP = " & GetIP2, , "GetIP2 中有错误发生!"
GetIP2 = ""
Exit Function
End Function
Public Function GetIP3() As String
On Error GoTo SoErr
Dim strSoundCode As String, strLineArray() As String, intStrCount As Integer
'获取 IP 地址。
GetIP3 = GetWebSoundCode("http://www.ip138.com/ip2city.asp")
GetIP3 = Mid$(GetIP3, InStr(GetIP3, Chr$(91)) + 1)
GetIP3 = Mid$(GetIP3, 1, InStr(GetIP3, Chr$(93)) - 1)
'确保获得的是一个 IP 地址。
strLineArray = Split(GetIP3, Chr$(46))
intStrCount = UBound(strLineArray)
If intStrCount < 3 Then Err.Raise 666 '产生一个自定义错误号的错误。
GetIP3 = GetIP3 & Chr$(9) & strSoundCode
intStrCount = lstrlen(GetIP3)
If intStrCount < 32 Then
GetIP3 = GetIP3 & String$(32 - intStrCount, Chr$(32))
Else
For intStrCount = 1 To intStrCount
If lstrlen(GetIP3) < 33 Then Exit For
GetIP3 = Mid$(GetIP3, 1, Len(GetIP3) - 1)
Next
End If
Exit Function
SoErr:
'MsgBox "程序运行时发生错误,错误信息如下:" & vbCrLf & _
"=========================================" & vbCrLf & _
"错误号:" & Err.Number & vbCrLf & _
"错误描述:" & Err.Description & vbCrLf & _
"错误源:" & Err.Source & vbCrLf & _
"变量 GetIP = " & GetIP3, , "GetIP3 中有错误发生!"
GetIP3 = ""
Exit Function
End Function
Public Function GetIP4() As String
On Error GoTo SoErr
Dim strLineArray() As String, intStrCount As Integer
'获取 IP 地址。
GetIP4 = GetWebSoundCode("http://vbnet.mvps.org/resources/tools/getpublicip.shtml")
GetIP4 = Mid$(GetIP4, InStr(GetIP4, Chr$(39)) + 1)
GetIP4 = Mid$(GetIP4, 1, InStr(GetIP4, Chr$(39)) - 1)
'确保获得的是一个 IP 地址。
strLineArray = Split(GetIP4, Chr$(46))
intStrCount = UBound(strLineArray)
If intStrCount < 3 Then Err.Raise 666 '产生一个自定义错误号的错误。
GetIP4 = GetIP4 & Chr$(9)
intStrCount = lstrlen(GetIP4)
If intStrCount < 32 Then
GetIP4 = GetIP4 & String$(32 - intStrCount, Chr$(32))
Else
For intStrCount = 1 To intStrCount
If lstrlen(GetIP4) < 33 Then Exit For
GetIP4 = Mid$(GetIP4, 1, Len(GetIP4) - 1)
Next
End If
Exit Function
SoErr:
'MsgBox "程序运行时发生错误,错误信息如下:&#