Questioin for Ron de Bruin

[Jenny B.]

Hi Ron,
I'm a big fan of your CDO procedure that sends emails from Excel avoiding
the security warnings – great idea. I'm currently using one of your send
programs and I'm wondering if you could help me to add on last step.
After reviewing your other email macros with added text body, I can’t quite
find one that exactly covers the one piece I need to add. I just need one
additional line of code to attach a copy of the “Account Mgmt Checklist†to
the second group in the program (noted in the routine). These recipients are
already pre-determined by front side by programming. The second part of the
code looks for "Sales" as the determinant for those recipients who would
receive the attachment. The “Sales†group would receive a spreadsheet and
message vs. the “Yes†group just getting the message.
Any thoughts would be greatly appreciated.
Thanks so much and I really think this CDO process is slick - Jenny B.



Option Explicit
Sub CDO_Personalized_Mail_Body()
Dim iMsg As Object
Dim iConf As Object
Dim cell As Range
Dim Flds As Variant

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set iConf = CreateObject("CDO.Configuration")

For Each cell In
Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value)
= "yes" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = cell.Value
.From = """Account Mgmt"" <[email protected]>"
.Subject = "New Book Entry Checklist" & " - " &
Sheets("Account Mgmt Checklist").Range("F5").Value
.TextBody = "Hello " & cell.Offset(0, -1).Value &
vbNewLine & vbNewLine & _
"Please review the Book Entry Checklist and
forward to the DMS Group when complete." _
& vbNewLine & vbNewLine & "Thank you - Account Management"
.Send
End With
Set iMsg = Nothing
End If
End If

If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value)
= "sales" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = cell.Value
.From = """Account Mgmt"" <[email protected]>"
.Subject = "New Book Entry Checklist" & " - " &
Sheets("Account Mgmt Checklist").Range("F5").Value
.TextBody = "Hello " & cell.Offset(0, -1).Value &
vbNewLine & vbNewLine & _
"Please review the Book Entry Checklist and
forward to the DMS Group when complete." _
& vbNewLine & vbNewLine & "Thank you - Account Management"

' looking to add one more line here that would attach a copy of "Account
Mgmt Checklist"

.Send
End With
Set iMsg = Nothing
End If
End If


Next cell

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

 

[Ron de Bruin]

Hi Jenny

Sorry, I not understand what you want

Can you give a example or send me the file private

 

[Jenny B.]

Hi Ron,

It's hard to point out exactly where in the code I’m looking to make the
edit, due to the inability to change colors or bold text in the Discussion
Forum email - it's challenging.

In the below code, I modified two sections each sending an email to a
different group of people. In this chunk I've attached, I'm looking to add
one more line (note where the arrows are) to have a single attachment added
which is a copy of the page/sheet "Account Mgmt Checklist".

Thanks again for your review - Jenny B.

If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value)
= "sales" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = cell.Value
.From = """Account Mgmt"" <[email protected]>"
.Subject = "New Book Entry Checklist" & " - " &
Sheets("Account Mgmt Checklist").Range("F5").Value
.TextBody = "Hello " & cell.Offset(0, -1).Value &
vbNewLine & vbNewLine & _
"Please review the Book Entry Checklist and
forward to the DMS Group when complete." _
& vbNewLine & vbNewLine & "Thank you - Account Management"
"Account Mgmt Checklist" here >>>>>>>>>>

.Send
End With
Set iMsg = Nothing
End If
End If

 

[Jenny B.]

Hi Ron,

One last note concerning CDO email process. I was using the CDO code noted
in my first email here at work. Up until today, everything worked just fine.
However, when I try to run it today - it does not work. No error, no
message, no nothing.

I was reading online that some others experienced similar problems, but
there was no sound reason for why this occurs. I am working off my work
server and I'm not sure if there are some restrictions of sorts that filter
it out after a certain amount of emails.

Have you run across this problem before? If so, do you know what it is so I
could possibly bring it up to our IT group?

Thanks again - Jenny B.

 

[Ron de Bruin]

If you want to add a single sheet workbook first create workbook from this sheet on your harddisk

This will save the sheet "Account Mgmt Checklist" in a single sheet workbook in C with the name
Worksheet: Account Mgmt Checklist

If you run this macro first you can add the path/name of this workbook in the mail macro in this line
..AddAttachment

Sub Test()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
Sheets("Account Mgmt Checklist").Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = "C:\"
TempFileName = "Worksheet: Account Mgmt Checklist"


With Destwb
Application.DisplayAlerts = False
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With


With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

 

[Ron de Bruin]

Security settings can block CDO using your SMTP
Your IT people can look at that

 

[Jenny B.]

Thanks so much Ron. Both of your solutions worked great. You were right
about the server. After speaking with IT, they noted that changing to
another server would work better for my application needs.

Thanks again and I really appreciate you sharing this CDO email method
online -

Jenny B.

 

[Ron de Bruin]

You are welcome