Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
Hi All,
Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
See
http://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in message ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
Hi Ron,
Yes they are. Cheers Bob On Jun 8, 12:00 am, "Ron de Bruin" wrote: Seehttp://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
Hi Ron,
After I sent my initial email, I tested with additional email addresses in the table I use. The result was of course a fresh email for every address. What I would like to do though is have a core number of "To" email addressses and a dynamic list of "cc" addresses if that is possible. Cheers Bob On Jun 8, 5:03 am, Ozbobeee wrote: Hi Ron, Yes they are. Cheers Bob On Jun 8, 12:00 am, "Ron de Bruin" wrote: Seehttp://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
Good morning
Try this See this two lines 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in message ... Hi Ron, After I sent my initial email, I tested with additional email addresses in the table I use. The result was of course a fresh email for every address. What I would like to do though is have a core number of "To" email addressses and a dynamic list of "cc" addresses if that is possible. Cheers Bob On Jun 8, 5:03 am, Ozbobeee wrote: Hi Ron, Yes they are. Cheers Bob On Jun 8, 12:00 am, "Ron de Bruin" wrote: Seehttp://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
Oops
Use this one Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value On Error Resume Next For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) On Error GoTo 0 .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Display End With Set OutMail = Nothing End If strCC = "" Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in message ... Good morning Try this See this two lines 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in message ... Hi Ron, After I sent my initial email, I tested with additional email addresses in the table I use. The result was of course a fresh email for every address. What I would like to do though is have a core number of "To" email addressses and a dynamic list of "cc" addresses if that is possible. Cheers Bob On Jun 8, 5:03 am, Ozbobeee wrote: Hi Ron, Yes they are. Cheers Bob On Jun 8, 12:00 am, "Ron de Bruin" wrote: Seehttp://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
On Jun 8, 8:00 pm, "Ron de Bruin" wrote:
Oops Use this one Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value On Error Resume Next For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) On Error GoTo 0 .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Display End With Set OutMail = Nothing End If strCC = "" Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in . .. Good morning Try this See this two lines 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi Ron, After I sent my initial email, I tested with additional email addresses in the table I use. The result was of course a fresh email for every address. What I would like to do though is have a core number of "To" email addressses and a dynamic list of "cc" addresses if that is possible. Cheers Bob On Jun 8, 5:03 am, Ozbobeee wrote: Hi Ron, Yes they are. Cheers Bob On Jun 8, 12:00 am, "Ron de Bruin" wrote: Seehttp://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub Hi Ron, Many thanks for taking the time to assist. The code works a treat. Cheers Bob Maitland Australia |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Add cc option to Send Mail + attachment
You are welcome Bob
-- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in message ... On Jun 8, 8:00 pm, "Ron de Bruin" wrote: Oops Use this one Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value On Error Resume Next For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) On Error GoTo 0 .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Display End With Set OutMail = Nothing End If strCC = "" Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in . .. Good morning Try this See this two lines 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") Sub Send_Files_test() 'Working in 2000-2007 Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range Dim rng As Range, rng2 As Range Dim CCcell As Range Dim strCC As String With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet1") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:K column in each row 'Enter the CC addresses in the L:P column in each row Set rng = sh.Cells(cell.Row, 1).Range("C1:K1") Set rng2 = sh.Cells(cell.Row, 1).Range("L1:P1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value For Each CCcell In rng2.SpecialCells(xlCellTypeConstants) If CCcell.Value Like "?*@?*.?*" Then strCC = strCC & CCcell.Value & ";" End If Next CCcell If Len(strCC) 0 Then strCC = Left(strCC, Len(strCC) - 1) .CC = strCC .Subject = "Testfile" .Body = "Hi " & cell.Offset(0, -1).Value For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi Ron, After I sent my initial email, I tested with additional email addresses in the table I use. The result was of course a fresh email for every address. What I would like to do though is have a core number of "To" email addressses and a dynamic list of "cc" addresses if that is possible. Cheers Bob On Jun 8, 5:03 am, Ozbobeee wrote: Hi Ron, Yes they are. Cheers Bob On Jun 8, 12:00 am, "Ron de Bruin" wrote: Seehttp://www.rondebruin.nl/mail/tips2.htm Are your mail addresses also in the table ? -- Regards Ron de Bruinhttp://www.rondebruin.nl/tips.htm "Ozbobeee" wrote in ... Hi All, Background: One base workbook creates separate workbooks with appropriate data for each team, then displays each of the teams emails (12) ready to send. At this stage I manually include people to cc the email to (this varies between the 12 emails) then send. Outcome: I would like to automate this process if I could. Detail: I have the following email code (thanks to Ron DeBruin) in the base workbook, but would like to add one or more cc's to it as well. Not sure if this is possible but would appreciate any assistance please? Regards Bob Sub Send_Files2() ' Loops through email addresses, attaches appropriate TL file to new email, then sends. Dim OutApp As Object Dim OutMail As Object Dim sh As Worksheet Dim cell As Range, FileCell As Range, rng As Range Sheets("Sheet15").Select Sheets("Sheet15").Select Columns("C:C").Select Selection.ClearContents Columns("G:G").Select Selection.Copy Range("C1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("A1").Select With Application .EnableEvents = False .ScreenUpdating = False End With Set sh = Sheets("Sheet15") Set OutApp = CreateObject("Outlook.Application") OutApp.Session.Logon For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConst ants) 'Enter the file names in the C:Z column in each row if multiple files to attach Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") If cell.Value Like "?*@?*.?*" And _ Application.WorksheetFunction.CountA(rng) 0 Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = cell.Value .Subject = "Subject - " & cell.Offset(0, 4).Value .Body = " Hi " & cell.Offset(0, 3).Value & "," & vbNewLine & vbNewLine & _ " The attached file details your team's statistics " & cell.Offset(0, 4).Value & vbNewLine & vbNewLine & _ " Regards," For Each FileCell In rng.SpecialCells(xlCellTypeConstants) If Trim(FileCell) < "" Then If Dir(FileCell.Value) < "" Then .Attachments.Add FileCell.Value End If End If Next FileCell .Display 'Or use Send '.Send End With Set OutMail = Nothing End If Next cell Set OutApp = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Sheets("Main").Select End Sub Hi Ron, Many thanks for taking the time to assist. The code works a treat. Cheers Bob Maitland Australia |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Send to mail recipient( as attachment) | Excel Programming | |||
Office 2003 Send To option of mail as attachment | Excel Discussion (Misc queries) | |||
Cannot "Send to -> mail recipient (as attachment)" | Excel Discussion (Misc queries) | |||
Activating the Send As Attachment option | Excel Worksheet Functions | |||
Send mail with attachment | Excel Programming |