Thread: Sendmail: Problem when used after a Userform
View Single Post
  #10   Report Post  
Posted to microsoft.public.excel.programming
Bernard Foot Bernard Foot is offline
external usenet poster
  
Posts: 4
Default Sendmail: Problem when used after a Userform
Ron,

I do not see "Mail Delivery" when I go into
OutlookToolsOptions. What I get is a dialogue box with
tabs for Preferences/Mail Services/Mail
Format/Spelling/Other/Delegates. I am working on a
company PC, so maybe that function has been locked down.

Anyway, here is the code. This code experiences the
problem: if the Send_Out_Mails command is moved before
the FormInitialise.Show statement then everything works
OK.

================================================== ===
Sub Process_Passport()

ErrMsg$ = ""

If Range("PassportID").Value = "" Or Range
("PassportID").Value = Range("PassID_Prompt").Value Then
ErrMsg$ = Chr$(10) & "Unique Pasport ID"
If Range("EstName").Value = "" Or Range("EstName").Value
= Range("EstName_Prompt").Value Then ErrMsg$ = ErrMsg$ +
Chr$(10) & "Establishment Name"
If Range("EstID").Value = "" Or Range("EstID").Value =
Range("EstID_Prompt").Value Then ErrMsg$ = ErrMsg$ +
Chr$(10) & "Establishment Name"

If ErrMsg$ < "" Then
MsgBox "The following data has not been entered:" &
Chr$(10) & ErrMsg$, vbOKOnly, "INVALID DATA !!!"
Exit Sub
End If

' If Passport Type or Days not yet set up ...
If Range("Passport_Type").Value = "" Or Range
("Passport_Days").Value = "" Then
FormInitialise.Show
' Quit if the Initialise dialoge box was cancelled
If Range("Passport_Type").Value = "" Or Range
("Passport_Days").Value = "" Then Exit Sub
End If

Unload FormInitialise

Send_Out_Mail

' Get confirmation that the entries are correct
FormConfirm.Show

If Range("Confirm_Form_OK").Value = 0 Then Exit Sub

' Set Passport heading
If Range("Passport_Type").Value = 1 Then
Range("Passport_Heading").Value = Range
("Passport_Heading").Value & "(Type 1: Microsoft
Technical Courses exc. Certification)"
Else
Range("Passport_Heading").Value = Range
("Passport_Heading").Value & "(Type 2: Applications,
Citrix, Cisco, Certification)"
End If

' Set up Part No. to be displayed
If Range("Passport_Type").Value = 1 Then
If Range("Passport_Days").Value = 10 Then
PartNo$ = Range("PN_1_10").Value
Else
PartNo$ = Range("PN_1_30").Value
End If
Else
If Range("Passport_Days").Value = 10 Then
PartNo$ = Range("PN_2_10").Value
Else
PartNo$ = Range("PN_2_30").Value
End If
End If

Range("RM_Part_No").Value = "RM Part No. " & PartNo$

' Set correct number of rows in the table
If Range("Passport_Days").Value = 10 Then
Rows("18:37").Delete Shift:=xlUp
Range("A17:G17").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End If

' save into a temporary file in case of a problem and
need to recover
FilePath$ = ActiveWorkbook.Path & "\"
On Error Resume Next
Kill FilePath$ & "Passport_WIP.xls"
On Error GoTo 0
ActiveWorkbook.SaveAs Filename:= _
FilePath$ & "Passport_WIP.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False

' Delete program button
ActiveSheet.Shapes("Button_Create").Delete

' Hide Comments
Application.DisplayCommentIndicator = xlNoIndicator

' Turn off row/col numbers
ActiveWindow.DisplayHeadings = False

' Sort e-mail, etc. lists to ensure no blank lines
Range("Control!C2:D100").Sort Key1:=Range("Control!C2"),
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

Range("Control!E2:F100").Sort Key1:=Range("Control!E2"),
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

Range("Control!G2:G100").Sort Key1:=Range("Control!G2"),
Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

' Enter Issue & Expiry Date
Range("Date_Issued_Label").Value = "Date Issued:"
Range("Issue_Date").Value = Date
Range("Expiry_Date_Label").Value = "Expiry Date:"
Range("PassportExpiry").Value = Date + Range
("Validity").Value
' Put borders around these two items
With Range("G4:G5")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
With Range("G4:G5").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("G4:G5").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("G4:G5").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("G4:G5").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Range("G4:G5").Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

' Hide Control sheet
Sheets("Control").Visible = False

' Print Hardcopies
If Range("Test_Mode").Value = 1 Or Range
("Test_Mode").Value = 2 Then GoTo hardcopy_done

' Unprotect workbook
ActiveWorkbook.Unprotect Password:="getCluedup"
ActiveSheet.Unprotect Password:="getCluedup"

' Print Customer Copy if no customer e-mail address given:
If Not Range("EstEmail").Value Like "*@*.*" Then

Range("Copy_Type").Value = "Customer Copy"
ActiveWindow.SelectedSheets.PrintOut Copies:=1,
Collate:=True

End If

For RowNo% = 2 To 100

If Worksheets("Control").Cells(RowNo%, 7).Value = ""
Then GoTo hardcopy_done

Range("Copy_Type").Value = Worksheets("Control").Cells
(RowNo%, 7).Value

' If this is a customer copy, print all pages (inc.
Notes, Ts&Cs), otherwise just print the Passport
If Range("Copy_Type").Value = "Customer Copy" Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1,
Collate:=True
Else
ActiveWindow.SelectedSheets.PrintOut From:=1,
To:=1, Copies:=1, Collate:=True
End If

Next RowNo%

hardcopy_done:
' Protect workbook
ActiveWorkbook.Protect Structu=True, Windows:=False,
Password:="getCluedup"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True, Password:="getCluedup"

Range("B8").Select

' Create new files
For RowNo% = 2 To 100

FilePath$ = Worksheets("Control").Cells(RowNo%,
5).Value
If FilePath$ = "" Then GoTo Filing_Done
If Not FilePath$ Like "*\" Then FilePath$ = FilePath$
& "\"
Filename$ = Mid(Range("EstName").Value, 1, 10) & "_"
& Range("PassportID").Value
' Unprotect workbook
ActiveWorkbook.Unprotect Password:="getCluedup"
ActiveSheet.Unprotect Password:="getCluedup"
Range("Copy_Type").Value = Worksheets("Control").Cells
(RowNo%, 6).Value
' Protect workbook
ActiveWorkbook.Protect Structu=True,
Windows:=False, Password:="getCluedup"
ActiveSheet.Protect DrawingObjects:=True,
Contents:=True, Scenarios:=True, Password:="getCluedup"

ActiveWorkbook.SaveAs Filename:= _
FilePath$ & Filename$, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False

Next RowNo%

Filing_Done:

' Send E-mails
If Range("Test_Mode").Value = 1 Or Range
("Test_Mode").Value = 3 Then GoTo emails_done

' If Customer e-mail has been specified ...
If Range("EstEmail").Value Like "*@*.*" Then

' Unprotect workbook
ActiveWorkbook.Unprotect Password:="getCluedup"
ActiveSheet.Unprotect Password:="getCluedup"
' Set copy type at top right of Passport
Range("Copy_Type").Value = "Customer Copy"
' Protect workbook
ActiveWorkbook.Protect Structu=True,
Windows:=False, Password:="getCluedup"
ActiveSheet.Protect DrawingObjects:=True,
Contents:=True, Scenarios:=True, Password:="getCluedup"

ActiveWorkbook.SendMail Recipients:=Range
("EstEmail").Value, Subject:="RM Training Passport: " &
Mid(Range("EstName").Value, 1, 10) & " " & Range
("PassportID").Value

End If


GoTo emails_done

For RowNo% = 2 To 100

If Worksheets("Control").Cells(RowNo%, 3).Value = ""
Then GoTo emails_done

' Unprotect workbook
ActiveWorkbook.Unprotect Password:="getCluedup"
ActiveSheet.Unprotect Password:="getCluedup"
' Set copy type at top right of Passport
Range("Copy_Type").Value = Worksheets("Control").Cells
(RowNo%, 4).Value
' Protect workbook
ActiveWorkbook.Protect Structu=True,
Windows:=False, Password:="getCluedup"
ActiveSheet.Protect DrawingObjects:=True,
Contents:=True, Scenarios:=True, Password:="getCluedup"

ActiveWorkbook.SendMail Recipients:=Worksheets
("Control").Cells(RowNo%, 3).Value, Subject:="RM Training
Passport: " & Mid(Range("EstName").Value, 1, 10) & " " &
Range("PassportID").Value

Next RowNo%

emails_done:

End Sub

Function Valid_Email(TestText$)

Valid_Email = 0

If UCase(TestText$) Like "[A-Z0-9]*@[A-Z0-9]*.[A-Z0-9]*"
Then Valid_Email = 1

End Function

Sub Send_Out_Mail()

For RowNo% = 2 To 100

If Worksheets("Control").Cells(RowNo%, 3).Value = ""
Then GoTo emails_done

ActiveWorkbook.Unprotect Password:="getCluedup"
ActiveSheet.Unprotect Password:="getCluedup"
Range("Copy_Type").Value = Worksheets("Control").Cells
(RowNo%, 4).Value
ActiveWorkbook.Protect Structu=True,
Windows:=False, Password:="getCluedup"
ActiveSheet.Protect DrawingObjects:=True,
Contents:=True, Scenarios:=True, Password:="getCluedup"
ActiveWorkbook.SendMail Recipients:=Worksheets
("Control").Cells(RowNo%, 3).Value, Subject:="RM Training
Passport: " & Mid(Range("EstName").Value, 1, 10) & " " &
Range("PassportID").Value
Next RowNo%

emails_done:

End Sub

-----Original Message-----
Hi Bernard

I have open a Virtual PC to check it and Outlook 200
have this setting in
ToolsOptionsMail Delivery

Post your code if this is not working

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Bernard Foot"
wrote in message news:2548201c46037$d359c500
...
Ron,

Your item 4 is:
========================
Because there is a bug in Outlook it is possible that
you
must uncheck
"send immediately when connect" in the Outlook options.
ToolsOptionsMail Setup in the Outlook menu.
=====================

Perhaps this is not for Outlook 2000? If I go into
ToolsOptions I do not see a Mail Setup choise.

I get Preferences/E-mail/E-mail options and Mail
Services, but I cannot see the "send immediately when
connect" setting.

Berni.


-----Original Message-----
There is a Bug in Outlook

http://www.rondebruin.nl/mail/problems.htm
Try number 4

--
Regards Ron de Bruin
http://www.rondebruin.nl


wrote in message
...
Hi, Ron.

Amazingly, I've already sent you an email about
this,
as
everywhere I looked on the web I saw your name!

I'm using Outlook 2000, Excel 2000, and WinXP Pro.

Regards,

Bernard.

-----Original Message-----
Hi Bernard

Do you use Outlook or Outlook Express

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Bernard Foot"

wrote in message news:2522601c4602e$26826b60
...
I have a VBA application which requires the same
workbook
to be sent (using sendmail) to multiple
recipients,
one
at a time. (The VBA loops through a list of
users,
amending the workbook before each mailing.)

The first recipient mailing works OK, but Excel
crashes
when it tries to process sendmail for the second
time.
This problem only arises where the sendmail loop
appears
after a userform.show in the same module. I've
tried
using both userform.hide and unload userform,
putting
in
a delay between sendmails, putting the
userform.show
into
a different module. The problem occurs even if I
show a
userform with absolutely nothing in it, and just
terminate the form.

Any ideas?


.



.



.

Reply With QuoteReply With Quote