很急了,弄了一整天都没改好,请高手帮忙啊....

Public Function SendEmail(ByVal ToEmail As String, Optional FromEmail As String = "", Optional Subject As String = "", Optional Contents As String = "") As Boolean
    SendEmail = True
    Dim objCfg, objMsg
        Set objCfg = CreateObject("CDO.Configuration")
    
        Dim objCfgFlds
        Set objCfgFlds = objCfg.Fields
        With objCfgFlds
            .Item(cdoSendUsingMethod) = cdoSendUsingPort
            .Item(cdoSMTPServer) = SMTPServer 
            .Item(cdoSMTPUseSSL) = False
            .Item(cdoSMTPAuthenticate) = 1
            .Item(cdoSMTPConnectionTimeout) = 7
            .Item(cdoSMTPAccountName) = AccountName
            .Item(cdoSendUserName) = username 
            .Item(cdoSendPassword) = PWD 
            .Item(cdoUseMessageResponseText) = True
            .Item(cdoLanguageCode) = "zh-cn"
            .Update
        End With
On Error GoTo e:
        Set objMsg = CreateObject("CDO.Message")
        With objMsg
            Set .Configuration = objCfg
            .To = ToEmail
            .From = IIf(FromEmail = "", AccountName, FromEmail)
            .Subject = Subject
            .TextBody = Contents
            .Send    '----------问题的重点.--------------
        End With
        Set objMsg = Nothing
        Set objCfgFlds = Nothing
        Set objCfg = Nothing
        Exit Function
e: SendEmail = False
    Err.Clear
End Function这是一个发邮件的函数,但是每次发邮件的时候，到了“.Send”就会经常反应很久都回不来.请各位高手帮忙解决一下,看有什么办法降低响应的时间,或者超N秒后强制退出.只要能将速度提上来就可以了，就是说，我不想发一封邮件就花去一两分钟，否则发送几百封就真的是等到花儿也谢了.