Visual Basic-手机归属查询

偶然间看到了一份手机号码归属地的数据库，9000多页的内容真是惊呆了，想着把它做成C++，但UI着实不咋样，索性用Visual Basic写了一份基于网络的手机归属查询。

结构很简单，用一张picture做背景，增加一个Textbox，三个Label（一个输出，一个作为拖动窗口，一个作为关闭按钮）和一个Image（负责command类此的效果）。

数据库基于网络，也就是说必须联网才可以使用。

网络接口API是从网上找的， "http://www.096.me/api.php?phone=" + phone + "&mode=txt"，其中phone就是手机号码。

利用两个函数获取网页的源码从而提取出来了手机归属地的信息，并利用Label. caption显示出来。

获取网页源码的函数：

Function getHTTPPage(url) '获取网站源码
On Error Resume Next
Dim http
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
getHTTPPage = http.Send()
If http.ReadyState <> 4 Then
Debug.Print "无法连接服务器"
getHTTPPage = "无法连接服务器"
Exit Function
End If
getHTTPPage = BytesToBstr(http.responseBody, "GB2312")
Set http = Nothing
End Function


Function BytesToBstr(body, Cset) '转码
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write body
objstream.position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function

利用label，将label的属性backstyle=0即可，更改名称为：labFormTitle增加源码：

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const HTCAPTIO = 2

Private Sub labFormTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ReleaseCapture 'WM_SYS向窗体发送一个移动窗体命令
    Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTIO, 0)
'SC_MOVE+ HTCAPTIO表示单击左键移动窗体
End Sub

Function GetByDiv(ByVal code As String, ByVal divBegin As String, divEnd As String)  '获取分隔符所夹的内容
    Dim lgStart As Long
    Dim lens As Long
    Dim lgEnd As Long
    lens = Len(divBegin)
    lgStart = InStr(1, code, divBegin) + CLng(lens)
    lgEnd = InStr(lgStart, code, divEnd)
    GetByDiv = Mid(code, lgStart, lgEnd - lgStart)
End Function

Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const HTCAPTIO = 2
Private Sub Image1_Click()
Dim phone
Dim web As String
Dim tem As String
phone = Text1.Text
web = "http://www.096.me/api.php?phone=" + phone + "&mode=txt"
'Text2.Text = web
tem = getHTTPPage(web)
Label1.Caption = GetByDiv(tem, "||", "||")
End Sub

Function getHTTPPage(url) '获取网站源码
On Error Resume Next
Dim http
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
getHTTPPage = http.Send()
If http.ReadyState <> 4 Then
Debug.Print "无法连接服务器"
getHTTPPage = "无法连接服务器"
Exit Function
End If
getHTTPPage = BytesToBstr(http.responseBody, "GB2312")
Set http = Nothing
End Function


Function BytesToBstr(body, Cset) '转码
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write body
objstream.position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function

Function GetByDiv(ByVal code As String, ByVal divBegin As String, divEnd As String)  '获取分隔符所夹的内容
    Dim lgStart As Long
    Dim lens As Long
    Dim lgEnd As Long
    lens = Len(divBegin)
    lgStart = InStr(1, code, divBegin) + CLng(lens)
    lgEnd = InStr(lgStart, code, divEnd)
    GetByDiv = Mid(code, lgStart, lgEnd - lgStart)
End Function
Private Sub labFormTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ReleaseCapture 'WM_SYS向窗体发送一个移动窗体命令
    Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTIO, 0)
'SC_MOVE+ HTCAPTIO表示单击左键移动窗体
End Sub
Private Sub Label2_Click()
End
End Sub
Private Sub Picture1_Click()

End Sub

GUI 比较单一，用了最简单的结构，效果还是一般吧。

虽然网上有很多类似的软件，可是制作的过程是快乐的。

@ Mayuko