Issue with mMessage.Send in SendEmail - takes long time to send message

Hi,

I am using below code to send email with an excel as attachment.

Whenever i try to send the email it takes almost 3 to 4 ins to send mail.

when i debugged, at line mMessage.Send it takes 3 to 4 mins.

Can any of you suggest me some solution on the same.

Function SendEmail(mFrom, mTo, mSubject, mBody, mAttachment)
Dim RemoteSMTPServer
Dim SMTPPortNumber
Dim HTMLLinkToLogFile
Dim schema
Dim mConfig
Dim mMessage, i

Err.Clear
On Error Resume Next

schema = "http://schemas.microsoft.com/cdo/configuration/"
Set mConfig = Sys.OleObject("CDO.Configuration")
mConfig.Fields.Item(schema + "sendusing") = 2 ' cdoSendUsingPort

RemoteSMTPServer = SMTPSERVER  //not giving the server name due to confidential.
SMTPPortNumber = 25'

mConfig.Fields.Item(schema + "smtpserver") = RemoteSMTPServer ' SMTP server
mConfig.Fields.Item(schema + "smtpserverport") = SMTPPortNumber ' Port number
mConfig.Fields.Update()

Set mMessage = Sys.OleObject("CDO.Message")
mMessage.Configuration = mConfig
mMessage.From = mFrom
mMessage.To = mTo
mMessage.Subject = mSubject
mMessage.HTMLBody = mBody

' aqString.ListSeparator = ","
' For i = 0 To GetCSVCount(mAttachment) - 1
' mMessage.AddAttachment GetCSVItem(mAttachment, i)
' Next
' aqString.ListSeparator = ","
' For i = 0 To aqString.GetListLength(mAttachment) - 1
' mMessage.AddAttachment aqString.GetListItem(mAttachment, i)
' Next

If 0 < Len(mAttachment) Then
call mMessage.AddAttachment(mAttachment)
End If


mMessage.Send

If Err.Number > 0 Then
Log.Error "E-mail cannot be sent", Err.Description
SendEMail = False
Else
Log.Message "Message to <" + mTo + "> was successfully sent"
SendEMail = True
End If

End Function