Tweaking an Outlook email Macro in Excel

[John V]

I have a 'working' macro to send emails from Excel. However, I have two
issues remaining:
1. The amount of time per email is about 5 seconds. The bottleneck seems to
be the Outlook warning that 'another program is trying to access Outlook.'
The code below uses Express ClickYes, which waives the warning. I had also
tried sending email using CDO code, but could not get it to work with my
email and/or proxy server. Do you see a way to speed things up?

2. I would like to add code that would turn off (deselect) the 'Immediate
Send' option in Outlook. Can anyone help with that syntax please?

Thanks in advance, John

*************** Code follows ******************
Sub GroupProjects()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Dim SigString As String, Cmts As String, SBJ As String
Dim Signature As String
Dim Assgn As String, TxtBody As String, Finished As Boolean
Dim StuID As Variant, rng As Range, rng1 As Range
Dim PtsToDate As Variant, MaxPts As Variant, GradeToDate As String, Nick
As String
Dim Product As String, FcastVariance As Variant, FcastCalcVariance As
Variant, AssgnPts As Variant, TotAssignPts As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
' Register a message to send
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")

' Find ClickYes Window by classname
wnd = FindWindow("EXCLICKYES_WND", 0&)

' Send the message to Resume ClickYes
Res = SendMessage(wnd, uClickYes, 1, 0)

On Error GoTo cleanup
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\xxx Formal Office.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Assgn = Range("B1").Value 'Name of the assignment
TotAssignPts = Range("B2") ' Max pts for the assignment
Finished = Range("B3").Value 'Whether assignment has been noted as completed
If Not (Finished) Then
MsgBox ("Assignment has not been flagged as being complete. No further
action taken.")
Exit Sub
End If
ans = MsgBox("Getting ready to send emails to all students. You should have
turned off AutoSend in Outlook. Continue?", vbYesNo)
If ans = vbNo Then Exit Sub
SBJ = "Your grade for " & Assgn
SBJ = InputBox("Enter the subject line for this email.", "Email Subject", SBJ)
Set rng = Worksheets("Summary").Range("D290") 'Student ID Column for
searches
For Each cell In Range("D29100").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value <> "" Then
StuID = cell.Value
AssgnPts = cell.Offset(0, 1).Value 'This is the override column
Cmts = cell.Offset(0, 2).Value 'Comments
Res = Application.Match(StuID, rng, 0)
If Not IsError(Res) Then 'get summary data from Summary sheet
Set rng1 = rng(Res, 1)
PtsToDate = rng1.Offset(0, 1).Value
MaxPts = rng1.Offset(0, 2).Value
GradeToDate = rng1.Offset(0, 3).Value
Nick = rng1.Offset(0, -2)
End If
TxtBody = "Dear " & Nick & "," & vbNewLine & _
vbNewLine & "Your team's grade for the " & Assgn & " assignment
was " & AssgnPts & " points out of a possible " & TotAssignPts & "."
If Cmts <> "" Then
TxtBody = TxtBody & vbNewLine & vbNewLine & "The following
comment was noted: " & Cmts & "."
End If
TxtBody = TxtBody & vbNewLine & vbNewLine & "Including this team
assignment, you have individually accumulated a total of " & PtsToDate & "
out of a possible " & MaxPts & " points for an implied grade to date of '" &
GradeToDate & "'."
TxtBody = TxtBody & vbNewLine & vbNewLine & "Best wishes." &
vbNewLine & Signature

Set OutMail = OutApp.CreateItem(olMailItem)

With OutMail
.To = cell.Value & "@xxxx.edu"
.Subject = "Your Grade For " & Assgn
.Body = TxtBody
.Send 'Or use Display
End With
Set OutMail = Nothing
End If
Next cell
cleanup:
Res = SendMessage(wnd, uClickYes, 0, 0)

Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
**************************************