ASP/VBScript通过飞信实现发送短信和短消息功能(Fetion SMS)

提醒：本页面将不再更新、维护或者支持，文章、评论所叙述内容存在时效性，涉及技术细节或者软件使用方面不保证能够完全有效可操作，请谨慎参考！

前一段时间正好对电脑发送短信比较感兴趣，因为自己那款老掉牙的手机慢慢的输入文字再群发确实很不方便，于是想移动有没有开放短信接口什么的，上网搜索了有关短信发送的相关知识，找到了Demon的这篇关于《VBS短信飞信发送类（VBSFetion）》，原来是利用了移动的WAP飞信，然后模拟POST，实现短信或者飞信的发送，优点是发送免费，唯一遗憾的是貌似只能发给自己或者飞信好友。不过发送给自己倒是个不错的功能，可以实现一些监控报警类的功能。其实139邮箱那个短信发送到是可以发给任何人，只不过是按正常短信收费标准进行收费，而且主显号码是在你原先的号码上附加了一串长号，这点有点不爽。鉴于Demon在这一方面已经先行一步，我就利用其算法，改造了自己的一个VBScript类实现。

不过值得注意的是，所有POST或者GET发送的消息需要进行编码处理，在ASP中这点还是比较容易的，直接Server.URLEncode就可以了，但是在本机脚本WScript环境下却要费一番周折。网上查找了一下资料，这次仍然找到了Demon的解决方案《用VBS实现PHP的urlencode函数》。好了，基本上解码就分为ANSI版和UTF-8版，我将其改写如下：

Class UriParser
  Private Function isUpper(c)
    isUpper = CBool( Asc(c) >= Asc("A") _
      And Asc(c) <= Asc("Z") )
  End Function
  
  Private Function isLower(c)
    isLower = CBool( Asc(c) >= Asc("a") _
      And Asc(c) <= Asc("z") )
  End Function
  
  Private Function isAlpha(c)
    isAlpha = CBool(isUpper(c) Or isLower(c))
  End Function
  
  Private Function isSpace(c)
    isSpace = CBool(Asc(c) = Asc(" "))
  End Function
  
  ' // Thanks Demon
  ' // See http://demon.tw/programming/vbs-php-urlencode.html
  Public Function encode(str, charset)
    Dim i,c
    For i = 1 To Len(str)
      c = Mid(str, i, 1)
      If isAlpha(c) Or c = "-" Or c = "_" Or c = "." Then
        encode = encode & c
      ElseIf isSpace(c) Then
        encode = encode & "+"
      Else
        If UCase(charset) = "UTF-8" Then
           Dim s : s = c
           c = "&H" & Hex(AscW(c))
           If c >= &H0001 And c <= &H007F Then
            encode = encode & s
           ElseIf c > &H07FF Then
            encode = encode & "%" & _
              Hex(&HE0 Or (c\(2^12) And &H0F))
            encode = encode & "%" & _
              Hex(&H80 Or (c\(2^6) And &H3F))
            encode = encode & "%" & _
              Hex(&H80 Or (c\(2^0) And &H3F))
          Else
            encode = encode & "%" & _
              Hex(&HC0 Or (c\(2^6) And &H1F))
            encode = encode & "%" & _
              Hex(&H80 Or (c\(2^0) And &H3F))
          End If
        Else
           c = Asc(c)
           encode = encode & "%" & Left(Hex(c),2)
           encode = encode & "%" & Right(Hex(c),2)
        End If
      End If
    Next
  End Function
End Class

核心函数参考了Demon的实现，除了需要编码的str参数外，附加了以什么编码方式编码的charset参数。也就是说我们在实现模拟浏览器POST消息给WAP飞信时需要确定其传输的编码，当然我们可以用手机模拟器试着登录并抓取header得到编码后硬编码进我们的脚本里，在这里我试着在初始化时GET一次WAP飞信的首页，然后再提取出其编码方式，这个编码方式然后提供给接下来的消息传输编码用。好了，说了这么多，先把我的代码实现展示出来吧：

' // Author: WangYe
' // Site: http://wangye.org
' // Thanks Demon
' // See http://demon.tw/my-work/vbsfetion.html
Class FetionMessager
  Private BASE_URI
  Private INDEX_DIR
  Private LOGIN_SUBMIT_DIR
  Private LOGOUT_SUBMIT_DIR
  Private SMS_SUBMIT_DIR
  Private FETION_SUBMIT_DIR
  Private FETION_MYSELF_SUBMIT_DIR
  Private SEARCH_SUBMIT_DIR
  Private GPRS_WAP_IPADDR
  
  Private request_devid
  Private http
  Private content_charset
  Private regex
  
  Private status_code
  Private status_message
  Private error_occured
  
  Private Sub Class_Initialize()
    BASE_URI = "http://f.10086.cn"
    INDEX_DIR = "/im/index/indexcenter.action"
    LOGIN_SUBMIT_DIR = "/im/login/inputpasssubmit1.action"
    LOGOUT_SUBMIT_DIR = "/im/index/logoutsubmit.action"
    FETION_SUBMIT_DIR = "/im/chat/sendMsg.action"
    FETION_MYSELF_SUBMIT_DIR = "/im/user/sendMsgToMyselfs.action"
    SMS_SUBMIT_DIR = "/im/chat/sendShortMsg.action"
    SEARCH_SUBMIT_DIR = "/im/index/searchOtherInfoList.action"
    GPRS_WAP_IPADDR = "10.0.0.172"
    
    status_code = 0
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set regex = New RegExp
  End Sub
  
  Private Sub Class_Terminate()
    Set regex = Nothing
    Set http = Nothing
  End Sub
  
  Private Function encodeURI(str)
    Dim uri
    Set uri = New UriParser
    encodeURI = uri.encode(str, getContentCharset())
    Set uri = Nothing
  End Function
  
  Private Function buildLoginParameters(mobile, password, status)
    buildLoginParameters = "m=" & encodeURI(mobile) & _
      "&pass=" & encodeURI(password) & "&loginstatus=" & status
  End Function
  
  Private Function buildMessageParameters(msg)
    buildMessageParameters = "msg=" & encodeURI(msg)
  End Function
  
  Private Function buildUserIdParameters(uid)
    buildUserIdParameters = "touserid=" & encodeURI(uid)
  End Function
  
  Private Function buildSearchTextParameters(text)
    buildSearchTextParameters = "searchText=" & encodeURI(text)
  End Function
  
  Private Function buildUrl(url, param)
    buildUrl = url & "?" & param
  End Function
  
  Private Function request(ByVal url, data, method)
    method = UCase(method)
    url = BASE_URI & url
    http.open method, url, False
    http.setRequestHeader "Accept", _
      "text/xml,application/xml,application/xhtml+xml," & _
      "text/html;q=0.9,text/plain;q=0.8,text/vnd.wap.wml,image/png," &_
      "application/java-archive,application/java,application/x-java-archive," &_
      "text/vnd.sun.j2me.app-descriptor,application/vnd.oma.drm.message," &_
      "application/vnd.oma.drm.content,application/vnd.oma.dd+xml," &_
      "application/vnd.oma.drm.rights+xml,application/vnd.oma.drm.rights+wbxml," &_
      "application/x-nokia-widget,text/x-opml,*/*;q=0.5"
    
    http.setRequestHeader "User-Agent", _
      "Mozilla/5.0 (SymbianOS/9.4; U; Series60/5.0 " &_
      "Nokia5800d-1/52.50.2008.37; Profile/MIDP-2.1 Configuration/CLDC-1.1 ) " &_
      "AppleWebKit/413 (KHTML, like Gecko) Safari/413"
    
    http.setRequestHeader "X-Forwarded-For", GPRS_WAP_IPADDR
    http.setRequestHeader "Forwarded-For", GPRS_WAP_IPADDR
    http.setRequestHeader "Client_IP", GPRS_WAP_IPADDR
    http.setRequestHeader "Client-IP", GPRS_WAP_IPADDR
    http.setRequestHeader "VIA", GPRS_WAP_IPADDR
    http.setRequestHeader "REMOTE_ADDR", GPRS_WAP_IPADDR
    http.setRequestHeader "REMOTE-ADDR", GPRS_WAP_IPADDR
    http.setRequestHeader "X-Nokia-MusicShop-Bearer", "GPRS/3G"
    http.setRequestHeader "X-Nokia-MusicShop-Version", "11.0842.9"
    http.setRequestHeader "X-Wap-Profile", _
      "http://nds1.nds.nokia.com/uaprof/Nokia5800d-1r100-3G.xml"
    http.setRequestHeader "X-Online-Host", _
      Replace(Replace(BASE_URI, "http://", ""), "https://", "")
    
    If Not IsEmpty(request_devid) Then
      http.setRequestHeader "x-up-calling-line-id", request_devid
      http.setRequestHeader "X-Up-subno", request_devid
    End If
    
    If method = "POST" Then
      http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      http.setRequestHeader "Referer", BASE_URI & INDEX_DIR
      http.send data
    Else
      http.send
    End If
    request = http.responseText
  End Function
  
  Private Function post(url, data)
    post = request(url, data, "POST")
  End Function
  
  Private Function getContentCharset()
    If IsEmpty(content_charset) Then
      Dim contentType
      Call request(INDEX_DIR, Null, "GET")
      contentType = http.getResponseHeader("Content-Type")
      regex.IgnoreCase = True
      regex.Global = False
      regex.Pattern = "^[\w\/\.]+; charset=(.+)$"
      If regex.Test(contentType) Then
         Dim matches
         Set matches = regex.Execute(contentType)
         content_charset = matches.Item(0).Submatches(0)
         Set matches = Nothing
      End If
    End If
    If IsEmpty(content_charset) Then content_charset = "UTF-8"
    getContentCharset = content_charset
  End Function
  
  Private Function parseLoginMessage(str)
    On Error Resume Next
    error_occured = False

    Dim login_status, login_message
    regex.IgnoreCase = True
    regex.Global = True
    regex.Pattern = "ontimer\=[""']" & _
      Replace(Replace(Replace(BASE_URI & INDEX_DIR, "/", "\/"), ".", "\."), ":", "\:")
    ' Succeeded
    If regex.Test(str) Then
      login_status = True
    Else
      regex.Pattern = "ontimer\=[""']" & _
        Replace(Replace(INDEX_DIR, "/", "\/"), ".", "\.")
      login_status = regex.Test(str)
      ' ontimer="/im/login/login.action
      ' login_status = False
    End If
    regex.Pattern = "timer value\=[""']\d+[""'] *\/>\s*<p>\s*(.+?[^<\s])\s*[^<]<br"
    If regex.Test(str) Then
      Dim matches
      Set matches = regex.Execute(str)
      login_message = matches.Item(0).Submatches(0)
      Set matches = Nothing
    End If
    If Err.Number<>0 Then
      login_status = Err.Number
      login_message = Err.Description
      error_occured = True
      Err.Clear
    End If
    parseLoginMessage = Array(login_status, login_message)
  End Function
  
  Private Function parseLogoutMessage(str)
    On Error Resume Next
    error_occured = False
    
    Dim logout_status, logout_message
    
    regex.IgnoreCase = True
    regex.Global = True
    regex.Pattern = "<card id\=""start"" title\="".+[^""]"">\s*<p>\s*<img"
    logout_status = regex.Test(str)
    If Not logout_status Then
      regex.Pattern = _
        "<card id\=""start"" title\="".+[^""]"">\s*<p>\s*(.+?[^<\/\\\s])\s*<br"
      logout_status = regex.Test(str)
      If logout_status Then
        Dim matches
        Set matches = regex.Execute(str)
        logout_message = matches.Item(0).Submatches(0)
        Set matches = Nothing
      End If
    Else
      logout_status = False
    End If
    If Err.Number<>0 Then
      logout_status = Err.Number
      logout_message = Err.Description
      error_occured = True
      Err.Clear
    End If
    parseLogoutMessage = Array(logout_status, logout_message)
  End Function
  
  Private Function parseSendMessage(str)
    On Error Resume Next
    error_occured = False

    Dim send_status, send_message
    regex.IgnoreCase = True
    regex.Global = True
    regex.Pattern = "<card id\=""start"" title\=""(.+?[^""' ])"""
    send_status = regex.Test(str)
    If send_status Then
      Dim matches
      Set matches = regex.Execute(str)
      send_message = matches.Item(0).Submatches(0)
      ' send_message = "发送成功" Or send_message = "消息会话提示"
      ' fix Chinese characters in some platform
      If StrEqual(send_message, Array(21457, -28671, 25104, 21151)) Or _
         StrEqual(send_message, Array(28040, 24687, 20250, -29731, 25552, 31034)) Or _
         StrEqual(send_message, Array(28040, 24687, 20250, -29731)) Then
        send_status = True
      Else
        send_status = False
      End If
      Set matches = Nothing
      regex.Pattern = _
        "timer value\=[""']\d+[""'] *\/>\s*<p>\s*(.+?[^<\s\/])\s*[^<]<br"
      If regex.Test(str) Then
        Set matches = regex.Execute(str)
        send_message = matches.Item(0).Submatches(0)
        Set matches = Nothing
      End If
    End If
    
    If Err.Number<>0 Then
      send_status = Err.Number
      send_message = Err.Description
      error_occured = True
      Err.Clear
    End If
    parseSendMessage = Array(send_status, send_message)
  End Function
  
  Private Function convertPhoneNumberToUserId(mobile)
    convertPhoneNumberToUserId = -1
    Dim content
    content = post(SEARCH_SUBMIT_DIR, _
      buildSearchTextParameters(mobile))
    If http.status = 200 Then
      regex.IgnoreCase = True
      regex.Global = True
      regex.Pattern = "/toinputMsg\.action\?touserid=(\d+)"
      If regex.Test(content) Then
        Dim matches
        Set matches = regex.Execute(content)
        convertPhoneNumberToUserId = matches.Item(0).Submatches(0)
        Set matches = Nothing
      End If
    End If
  End Function
  
  Private Function StrEqual(str, arr)
    StrEqual = False
    If Len(str)<>(Ubound(arr)+1) Then
      Exit Function
    End If
    Dim i, n
    For i = 1 To Len(str)
      n = AscW(Mid(str, i, 1))
      If n<>arr(i-1) Then Exit Function
    Next
    StrEqual = True
  End Function
  
  ' 检查手机号码是否规范
  ' mobile : 要检查的手机号码
  Public Function isMobilePhoneNumberValid(mobile)
    regex.IgnoreCase = True
    regex.Global = False
    regex.Pattern = "^1[3|4|5|8]\d{9}$"
    isMobilePhoneNumberValid = regex.Test(mobile)
  End Function
  
  ' 状态代码，0表示成功
  Public Property Get StatusCode()
    StatusCode = status_code
  End Property
  
  ' 状态消息
  Public Property Get StatusMessage()
    StatusMessage = status_message
  End Property
  
  ' 是否发生错误
  Public Function hasErrorOccured()
    hasErrorOccured = error_occured
  End Function
  
  ' 登录飞信
  ' mobile : 手机号码账户
  ' password : 登录密码
  ' loginstatus : 登录状态（1 在线，2 忙碌，3 离开，4 隐身）
  Public Function login(mobile, password, loginstatus)
    request_devid = mobile
    login = False
    Dim content
    content = post(LOGIN_SUBMIT_DIR, _
      buildLoginParameters(mobile, password, loginstatus))
    If http.status<>200 Then
      Exit Function
    End If
    
    Dim status
    status = parseLoginMessage(content)
    login = status(0)
    
    If Not login Then
      status_code = 1
    Else
      status_code = 0
    End If
    status_message = status(1)
  End Function
  
  ' 登出
  Public Function logout()
    logout = False
    
    Dim content
    content = post(LOGOUT_SUBMIT_DIR, "")
    If http.status<>200 Then
      Exit Function
    End If
    
    Dim status
    status = parseLogoutMessage(content)
    logout = status(0)
    
    If Not logout Then
      status_code = 2
    Else
      status_code = 0
    End If
    status_message = status(1)
  End Function
  
  ' 发送短信
  ' msg : 短信文本
  ' mobile : 接收方手机号码
  Public Function sendSMS(msg, mobile)
    sendSMS = False
    Dim uid, url
    uid = convertPhoneNumberToUserId(mobile)
    If uid=-1 Then : status_code = 3 : Exit Function
    
    url = buildUrl(SMS_SUBMIT_DIR, buildUserIdParameters(uid))
    Dim content
    content = post(url, buildMessageParameters(msg))
    Dim status
    status = parseSendMessage(content)
    sendSMS = status(0)
    
    If Not sendSMS Then
      status_code = 4
    Else
      status_code = 0
    End If
    status_message = status(1)
  End Function
  
  ' 发送消息
  ' msg : 消息文本
  ' mobile : 接收方手机号码
  Public Function sendMessage(msg, mobile)
    sendMessage = False
    Dim uid, url
    uid = convertPhoneNumberToUserId(mobile)
    If uid=-1 Then : status_code = 3 : Exit Function
    
    url = buildUrl(FETION_SUBMIT_DIR, buildUserIdParameters(uid))
    Dim content
    content = post(url, buildMessageParameters(msg))
    Dim status
    status = parseSendMessage(content)
    sendMessage = status(0)
    
    If Not sendMessage Then
      status_code = 4
    Else
      status_code = 0
    End If
    status_message = status(1)
  End Function
  
  ' 给自己发消息
  ' msg : 消息文本
  Public Function sendMessageToOwn(msg)
    Dim content
    content = post(FETION_MYSELF_SUBMIT_DIR, buildMessageParameters(msg))
    
    Dim status
    status = parseSendMessage(content)
    sendMessageToOwn = status(0)
    
    If Not sendMessageToOwn Then
      status_code = 4
    Else
      status_code = 0
    End If
    status_message = status(1)
  End Function
End Class

在上述代码中，我对于WAP飞信返回的消息进行正则匹配和处理，基本上能够提取到WAP飞信返回的消息StatusMessage以及是否成功的状态码StatusCode。其中上述代码的核心部分则是伪造手机访问的请求方法request。并且对于来源IP也进行了伪造，来源IP定义于GPRS_WAP_IPADDR变量中，上网查询得知移动WAP网关代理IP是10.0.0.172。不过貌似单纯这样伪造，依旧被WAP飞信判断为来源于CMNET，不过不影响使用吧。关于这段代码可以这样使用：

Function DisplayStatus(obj)
  WScript.Echo "Code : " & obj.StatusCode & vbCrLf & _
	"MSG:" & objStatusMessage
End Function

Dim objFetionMsgr
Set objFetionMsgr = New FetionMessager

If objFetionMsgr.login("13800000000", "123456", 4) Then
  DisplayStatus objFetionMsgr

  objFetionMsgr.sendMessageToOwn "Message to me"
  DisplayStatus objFetionMsgr

  objFetionMsgr.sendMessage "Message to other", "13000000000"
  DisplayStatus objFetionMsgr

  objFetionMsgr.sendSMS "SMS to other", "13000000000"
  DisplayStatus objFetionMsgr

  objFetionMsgr.logout
  DisplayStatus objFetionMsgr

Else
  DisplayStatus objFetionMsgr
End If
Set objFetionMsgr = Nothing

下一篇文章将给大家介绍命令行完全使用的版本，敬请期待:-)

5 thoughts on this post

Demon Says:

February 05, 2012 19:54:30

好长。
1. 王晔 Says:
  
  February 05, 2012 20:00:57
  
  呵呵，可能考虑多了，比较长的还是模拟手机发送header的部分，现在唯一担心的就是怕WAP飞信改版，要不那些处理消息的正则就全部废了。
WScript/VBScript以命令行的方式通过飞信发送短信或短消息 | 王晔的流水账 Says:

February 05, 2012 20:11:37

[...] 文章导航 ← 上一篇 [...]
sp42 Says:

February 16, 2012 18:55:02

呵呵，这不可以在没有安装飞信的机子发信息，应急用，呵呵
1. 王晔 Says:
  
  February 16, 2012 21:51:55
  
  不需要安装飞信啊，这个是模拟登录WAP飞信的，和飞信客户端无关，能上网基本就可以了，但是接收方必须是你的飞信好友。

Comments are closed. / 此内容评论功能已经关闭。