登录  
 加关注
查看详情
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

miaozk2006

点滴积累与收藏:关于技术,关于生活

 
 
 

日志

 
 

VB 一个获得自己外网 IP 地址的程序代码  

2012-05-24 08:37:32|  分类: 编程-VB |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

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 "程序运行时发生错误,错误信息如下:" & vbCrLf & _
        "=========================================" & vbCrLf & _
        "错误号:" & Err.Number & vbCrLf & _
        "错误描述:" & Err.Description & vbCrLf & _
        "错误源:" & Err.Source & vbCrLf & _
        "变量 GetIP = " & GetIP4, , "GetIP4 中有错误发生!"
    GetIP4 = ""
    Exit Function
End Function

'e.g:
Private Sub Command1_Click()
    Dim strIP As String
    strIP = GetIP1()
    If Len(strIP) < 11 Then strIP = "无法得到外网IP地址"
    Text1.Text = strIP
End Sub

Private Sub Command2_Click()
    Dim strIP As String
    strIP = GetIP2()
    If Len(strIP) < 11 Then strIP = "无法得到外网IP地址"
    Text2.Text = strIP
End Sub
Private Sub Command3_Click()
    Dim strIP As String
    strIP = GetIP3()
    If Len(strIP) < 11 Then strIP = "无法得到外网IP地址"
    Text3.Text = strIP
End Sub
Private Sub Command4_Click()
    Dim strIP As String
    strIP = GetIP4()
    If Len(strIP) < 11 Then strIP = "无法得到外网IP地址"
    Text4.Text = strIP
End Sub

摘自:网络整理


VB相关


vbline的用法[]

画图工具的VB实现

VB 一个获得自己外网 IP 地址的程序代码

VB程序中实现IP地址子网掩码网关DNS的更改 []

VB 中应用 FSO 对象模型介绍(摘自网络)

[] VbFSO 对象的介绍

VB 画坐标轴

VB 二进制文件的操作

[VB]BMPJPGVBKeyCode常数用法

vb实时曲线的绘制和保存

VB操作EXCEL

vb初学回顾:最大公约数 最小公倍数 素数求取

vb 关于窗口样式的API以及处理文本的API参考

【引用】在VB6.0中实现弹出式菜单的几种方法

【引用】URLDownloadToFile_VB下载文件!

利用WinRar压缩和解压缩文件

VB 剪切板

VB实现指示窗口中拖动方框的程序

VB绘制走动的表针

如何用VB制作DLL文件

【引用】VB修改IP地址

VB多窗体退出代码

[]VB:如何检测到U盘的插拔(源代码)

巧用SendMessage函数扩展Treeview功能

vb中如何在任务管理器里面隐藏应用程序进程

如何实现VBEXCEL的无缝连接

一个API方式存取日志文件的模块[VB]

VB用记录集填充表格函数

VB打开文本文件各种方法

vb ClipBoard 剪切板应用(复制剪切粘贴)

【引用】窗口处理技巧大全 vb(窗体控件)

【转】 Md rd命令之VB

vb:读写文本文件

vb中实现真正锁定的带自定义菜单的文本控件

【引用】使用CommonDialogShowSave后如何判断是保存还是※取消?

vb 关于commondialog的多选VB获取Windows操作系统所有版本

vb UTF文本文件访问

VB编程中的Unicode vs Ansi

VBPiView4注册机

VB获取超过2G文件的大小

CopyMemory还要快的函数SuperCopyMemory

VB:编程效率快步提高之:十七种可用一行代码完成的技巧

VB画出来的五星红旗

Qt第一印象——QteQt


更多精彩>>>
  评论这张
 
阅读(1406)| 评论(0)

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2018