Is it Possiable to speed up CDO.Message.

I have the following code that sends out about 22,000 Emails.  However it send the emails at about 1 every 5 sec or so.  If I turn on my Norton it will go faster but then I use up 100% of my processor sending them out.  Is there a way to speed this up or is the slow down in my code.  The Email that is generated is about 200KB.  I pull all the information from the Database and build most of the email in a separate class then I add it to a string.  I then concatenate the string and add in small amount of changes to the Salutation and Unsubscribe button.

Any advice would be helpful.


------------------------------------------------------------------------------------------


                Dim objEmailHeader As wklyEmail = New wklyEmail
                Dim strEmailHeader As String = objEmailHeader.emailHeader
                Dim strEmailSubscribe As String = objEmailHeader.emailSubscribe
                Dim strEmailFooter As String = objEmailHeader.emailFooter
                Dim strEmailBody As String = objEmailHeader.emailBody
                Dim strEmailBody1 As String = objEmailHeader.emailBody1
                Dim strEmailBody2 As String = objEmailHeader.emailBody2
                Dim strEmailBody3 As String = objEmailHeader.emailBody3
                Dim rsEmailList As ADODB.Recordset = objEmailHeader.rsEmailList
                Dim rsEmailCount As ADODB.Recordset = objEmailHeader.emailCount
                Dim strTopEmail As String
                Dim strBottomEmail As String

                strTopEmail = strEmailHeader + strEmailBody1
                strBottomEmail = strEmailBody2 + strEmailBody3 + strEmailBody

                If rsEmailList.EOF Then
                    MsgBox("The Email List was Empty.")
                    GoTo lastline
                Else
                    Me.lblEmailTotal.Text = rsEmailCount("EmailCount").Value
                    Dim n As Integer
                    Dim m As Integer
                    n = 0
                    m = 0

                    ' Finish building email and sending
                    Do
                        Dim strName As String
                        If Not IsDBNull(rsEmailList("fldFirstName").Value) Then
                            strName = rsEmailList("fldFirstName").Value
                        Else
                            strName = "0"
                        End If
                        'adding name and id to Salutation and Unsubscribe.
                        Dim strEmailSalutation As String = objEmailHeader.emailSalutation(strName)
                        Dim strEmailUnsubScribe As String = objEmailHeader.emailUnsubscribe(rsEmailList("idEmailService").Value)

                        'add Email for the Wkly Email to the email object
                        newMail.Body = strTopEmail + strEmailHeader + strBottomEmail + strEmailUnsubScribe + strEmailFooter
                        n = n + 1
                        'Adding new EmailAddress to the email.
                        newMail.To = rsEmailList("fldEmailAddress").Value

                        Try
                            mailServer.Send(newMail)
                        Catch c As Exception
                            MessageBox.Show(c.InnerException.InnerException.ToString())
                        End Try

                        ' update Database the email has been sent
                        Dim cmdUpdateEmail As New ADODB.Command
                        cmdUpdateEmail.CommandText = "updateEmailService"
                        cmdUpdateEmail.CommandType = ADODB.CommandTypeEnum.adCmdStoredProc
                        cmdUpdateEmail.ActiveConnection = objConn
                        cmdUpdateEmail.Parameters.Append(cmdUpdateEmail.CreateParameter("@idEmailService", ADODB.DataTypeEnum.adInteger, ADODB.ParameterDirectionEnum.adParamInput, 4, rsEmailList("idEmailService").Value))
                        cmdUpdateEmail.Execute()
                        ' updating form's email counter.
                        Me.lblEmailNeed.Text = Me.lblEmailTotal.Text - n
                        Me.lblCount.Text = n
                        rsEmailList.MoveNext()
                    Loop Until rsEmailList.EOF



--------------------------------------------------------------------------------------