PDA

View Full Version : UserForm control for a background process



scott56
06-25-2008, 09:43 PM
Hi,

I have developed a form that when activated starts a routine to Send a series of emails dependent on data within a sheet and a template.

This works fine if the user does not want to halt the process of Sending the emails as it continues through each email and then completes successfully.

If I try to include a "Pause / Continue" button to the form that is reporting progress on Sending the emails....when the "Pause / Continue" button is selected it stops processing of the Send email routine and gives control to the "Pause / Continue" Click event.....even if I try to return to the same point in the Send mail routine a problem occurs as a send mail call has been broken halfway through.

I have tried all sorts of things from application.wait through to public variables to know when the email send is complete but I cannot seem to get it to work....

I have included below the Send Mail Routine and the Current "Pause / Continue" button code....any help appreciated



Sub SendCommunication()
'This will send the communication and update the form with progress

Dim strMessage As String
Dim strReturnMessage As String
Dim strReturnContactValue As String
Dim strSendEmailAddress As String
Dim blnEmailSent As Boolean
Debug.Print "Start of the Send Communication Routine - Records " & intTotalRecordsSent & " Current " & intCurrentListRecord & " Err " & Err.Number & " Descr " & Err.Description

Do While intCurrentListRecord <= DebtCollector_ContactDebtors.frmDebtorIncludeListBox.ListCount


Call SearchForAndParseDebtorDetail(DebtCollector_ContactDebtors.frmDebtorInclude ListBox.List(intCurrentListRecord - 1), _
strType, _
strRule, _
strContactDetails, _
strActualTemplate, _
strMessage, _
strReturnContactValue, _
strReturnMessage)

'Based on the type of communication setup the details to be display
Select Case strType
Case "eMail"
DebtCollector_Send.frmSendMessageTextBox.value = "Contact By " & strReturnContactValue & vbNewLine & _
"Subject " & streMailSubject & vbNewLine & _
strMessage
Case "SMS"
DebtCollector_Send.frmSendMessageTextBox.value = "Contact By " & strReturnContactValue & vbNewLine & _
vbNewLine & strMessage
Case "Letter"
DebtCollector_Send.frmSendMessageTextBox.value = "Contact By " & strReturnContactValue & vbNewLine & _
vbNewLine & strMessage
End Select

DebtCollector_Send.frmSendInformationLabel.Caption = "Sending record " & intCurrentListRecord & " of " & DebtCollector_ContactDebtors.frmDebtorIncludeListBox.ListCount
DebtCollector_Send.Repaint

'Now if the Test Email Address is specified replace the Email address with the Test Email address before sending
If Worksheets("User Settings").Range("UserSettingsEmailUseTestEmailAddress").value Then
strSendEmailAddress = Worksheets("User Settings").Range("UserSettingsEmailTestEmailAddress").value
Else
strSendEmailAddress = strReturnContactValue
End If

'Stop the processing if the Template is Invalid
If strReturnMessage = "Invalid Template" Then Exit Do

'If the Type is eMail and we have a value for the email address then send the email
If strType = "eMail" And strReturnContactValue <> "No Value Exists in File" Then

Debug.Print "Before Send Mail in Send Communication Routine - Records " & intTotalRecordsSent & " Current " & intCurrentListRecord & " Err " & Err.Number & " Descr " & Err.Description

Call CDOSendMail(Worksheets("User Settings").Range("UserSettingsEmailSMTPServerName").value, _
Worksheets("User Settings").Range("UserSettingsEmailSendUserName").value, _
Worksheets("User Settings").Range("UserSettingsEmailSendPassword").value, _
Worksheets("User Settings").Range("UserSettingsEmailSMTPServerPort").value, _
Worksheets("User Settings").Range("UserSettingsEmailReplyToAddress").value, _
Worksheets("User Settings").Range("UserSettingsEmailFromDetail").value, _
Worksheets("User Settings").Range("UserSettingsEmailUseSSL").value, _
strSendEmailAddress, _
streMailSubject, _
strMessage, _
blnEmailSent)

Debug.Print "After Send Mail in Send Communication Routine - Records " & intTotalRecordsSent & " Current " & intCurrentListRecord & " Err " & Err.Number & " Descr " & Err.Description

'If there has been a problem in sending the communication then exit
If Not blnEmailSent Then Exit Do

intTotalRecordsSent = intTotalRecordsSent + 1

ElseIf strType = "eMail" And strReturnContactValue = "No Value Exists in File" Then

'Update the Count and display to the Screen
intCountOfNoValue = intCountOfNoValue + 1
DebtCollector_Send.frmSendCountOfNoValueLabel.Caption = "Number of Records with No eMail address - " & intCountOfNoValue
End If

intCurrentListRecord = intCurrentListRecord + 1

DebtCollector_Send.frmPauseContinueButton.Enabled = True
Application.Wait Now + TimeValue("0:0:05")
DebtCollector_Send.frmPauseContinueButton.Enabled = False

Loop

DebtCollector_Send.frmSendNumberOfRecordsSentLabel.Caption = "Number of Records Sent - " & intTotalRecordsSent

Debug.Print "End of Send Communication Routine - Records " & intTotalRecordsSent & " Current " & intCurrentListRecord & " Err " & Err.Number & " Descr " & Err.Description

End Sub


Sub CDOSendMail(strSMTPServerName As String, _
strSendUserName As String, _
strSendPassword As String, _
strServerPort As String, _
strReplyToAddress As String, _
strFromDetails As String, _
blnUseSSL As Boolean, _
strContactEmailAddress As String, _
streMailSubject As String, _
strEmailBody As String, _
blnEmailSent As Boolean)
'This routine will send an email to the domain and settings set by the user in the User Settings sheet
Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
Dim objMessage As Object
blnEmailSent = True
blnSendMailInProgress = True

'If the user is connected to the internet then send the email message
If IsConnected = True Then

Set objMessage = CreateObject("CDO.Message")

objMessage.Subject = streMailSubject
objMessage.Sender = strSendUserName
objMessage.To = strContactEmailAddress
objMessage.TextBody = strEmailBody
objMessage.TextBody = objMessage.TextBody & vbNewLine & vbNewLine
objMessage.TextBody = objMessage.TextBody & "End of Message"
If strFromDetails <> "Not Specified" Then objMessage.from = strFromDetails
If strReplyToAddress <> "Not Specified" Then objMessage.ReplyTo = strReplyToAddress

'Setup the email configuraiton information.
'Had to remove these configuration items because I have not posted 5 times....

If Err <> 0 Then
Call MessageDisplay("Error", "Send Mail Problem")
blnEmailSent = False
End If

Debug.Print "Before Actual CDO Send Routine -" & " Err " & Err.Number & " Descr " & Err.Description

'Everything is now ready for sending the email...Catch any errors in the Message send process
On Error Resume Next
objMessage.Send
If Err <> 0 Then

Debug.Print "Inside Error 1 for CDO Send Routine -" & " Err " & Err.Number & " Descr " & Err.Description

Call MessageDisplay("Error", "Send Mail Problem")
blnEmailSent = False
End If

Else
Debug.Print "Inside Error 2 for CDO Send Routine -" & " Err " & Err.Number & " Descr " & Err.Description

Call MessageDisplay("Error", "Send Mail Problem")
blnEmailSent = False
End If
Debug.Print "End of CDO Send Routine -" & " Err " & Err.Number & " Descr " & Err.Description
' Return mouse pointer to normal display.
Application.Cursor = xlNormal
'Application.Wait Now + TimeValue("0:0:01")

blnSendMailInProgress = False
End Sub

Private Sub frmPauseContinueButton_Click()
'Now depending on the current status of the button either exit the routine or re-start sending the communication

If DebtCollector_Send.frmPauseContinueButton.Caption = "Pause" Then
DebtCollector_Send.frmPauseContinueButton.Caption = "Continue"
Exit Sub
End If

If DebtCollector_Send.frmPauseContinueButton.Caption = "Continue" Then
DebtCollector_Send.frmPauseContinueButton.Caption = "Pause"
Call SendCommunication
End If
End Sub