VB提交Http的问题

Question

'向指定的URL发送字符串。
'参数：iSendURL 目标地址；
'   iSendStr 发送的字符串；
'   MsgId ，返回网关分配给短信的ID，如果为空串，表示该短信网关没有接收
'返回值：出错信息号。返回 0 为操作成功。
Public Function fPostStr(iSendURL As String, iSendStr As String, msgId As String, Optional resText) As Integer
On Error GoTo lbError
    Dim xml_Http As New MSXML.XMLHTTPRequest
    Dim xmldoc1 As New MSXML.DOMDocument
    Dim xmlelement As MSXML.IXMLDOMElement
    Dim iErrNo As Integer
    Dim tTimeout As Single
    Dim sResType As String
    
    iSendStr = URLEncoding(iSendStr)
    Debug.Print iSendStr
    tTimeout = Timer
    xml_Http.open "POST", iSendURL, True
    xml_Http.setRequestHeader "Content-Length", Len(iSendStr)
    xml_Http.setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
    xml_Http.Send iSendStr
    Debug.Print iSendStr
    While xml_Http.readyState <> 4 And fIsTimeOut(tTimeout) < 0
        DoEvents '问题出在该循环上。
    Wend
    If fIsTimeOut(tTimeout) >= 0 Then
        xml_Http.abort
        fPostStr = -1
        Exit Function
    End If
    If xml_Http.Status <> 200 Then
        fPostStr = xml_Http.Status
        Exit Function
    Else
        xmldoc1.loadXML xml_Http.responseText
        'xmldoc1.Load xml_Http.responseStream
        If xmldoc1.parseError.errorCode <> 0 Then
            fPostStr = -1
            Exit Function
        Else
            sResType = xmldoc1.documentElement.getAttribute("type")
            Select Case sResType
                Case "sms"
                    Set xmlelement = xmldoc1.getElementsByTagName("messageid").Item(0)
                    msgId = Trim(xmlelement.Text)
                Case "error"
                    Set xmlelement = xmldoc1.getElementsByTagName("error").Item(0)
                    If xmlelement Is Nothing Then
                        iErrNo = -3
                    Else
                        iErrNo = xmlelement.getAttribute("type") * (-1)
                    End If
                    fPostStr = iErrNo
                    Exit Function
                Case "sentMessages"
                    If (Not IsMissing(Result)) Then
                        resText = xml_Http.responseText
                    Else
                        fPostStr = -5
                        Exit Function
                    End If
                Case Else
                    fPostStr = -2
                    Exit Function
            End Select
        End If
    End If
    fPostStr = 0
    Exit Function
lbError:
    fposgstr = -10 '内部错误
End Function-----------
Private Function fIsTimeOut(ByVal iTimeBefore As Single) As Single
    Dim tTimeNow As Single
    tTimeNow = Timer + 1
    If mTIMEOUT < 1 Then mTIMEOUT = 181
    fIsTimeOut = Switch(tTimeNow <= iTimeBefore, tTimeNow + 86400, 1, tTimeNow) - iTimeBefore - mTIMEOUT
End Function
-----------------------------------------------
While xml_Http.readyState <> 4 And fIsTimeOut(tTimeout) < 0
        DoEvents  '问题出在该循环上,循环的次数让程序等待了30多秒。
    Wend这个循环为什么大多数情况下会循环那么多次？

Answer 1

问题应该出在这个函数上面
Private Function fIsTimeOut(ByVal iTimeBefore As Single) As Single
    Dim tTimeNow As Single
    tTimeNow = Timer + 1
    If mTIMEOUT < 1 Then mTIMEOUT = 181
    fIsTimeOut = Switch(tTimeNow <= iTimeBefore, tTimeNow + 86400, 1, tTimeNow) - iTimeBefore - mTIMEOUT
End Function
这个函数起初运行非常的慢

Answer 2

超OUTLOOK软件(正式版)提供源码:安装盘:http://bbs.2ccc.com/uploads/huangtao/smartmail.part1.rar
http://bbs.2ccc.com/uploads/huangtao/smartmail.part2.rar

Answer 3

上面的兄弟
http://expert.csdn.net/expert/deeptree/rooms/20/list.xml怎 么得到列表啊
兄弟 
怎 样提交啊