K
Ken Hudson
I found the code string below a while back and don't remember the author. My
apologies for the lack of acknowledgement. This code sends workbooks to users
through Outlook. It works fine, but I wanted to customize it slightly. In the
line of code that begins with ".From" I want to enter a cell reference in a
workbook rather than have the sender's name hard coded. I tried:
..From = ThisWorkbook.Sheets(1).Range("F27").Value
and a couple of other variations, but can't get it to accept this cell
reference.
Anyone have the solution?
TIA.
-------------------------
Sub CDO_Mail_Every_Worksheet_File()
Dim iMsg As Object
Dim iConf As Object
Dim ws As Worksheet
Dim wb As Workbook
Dim WBname As String
Dim Flds As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"SMTP.va.gov"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") =
25
.Update
End With
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("A3").Value Like "?*@?*.?*" Then
ws.Copy
Set wb = ActiveWorkbook
WBname = "C:/Personal/" & ws.Name & ".xls"
wb.SaveAs WBname
wb.Close False
Set wb = Nothing
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("A3").Value
.CC = ThisWorkbook.Sheets(1).Range("F27").Value
.From = """Ken Hudson"" <[email protected]>"
.Subject = "FCP User Validation for " & ws.Name
.AddAttachment WBname
.TextBody = ThisWorkbook.Sheets(1).Range("A30")
.Send
End With
Set iMsg = Nothing
Kill WBname
End If
Next ws
Set iConf = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
apologies for the lack of acknowledgement. This code sends workbooks to users
through Outlook. It works fine, but I wanted to customize it slightly. In the
line of code that begins with ".From" I want to enter a cell reference in a
workbook rather than have the sender's name hard coded. I tried:
..From = ThisWorkbook.Sheets(1).Range("F27").Value
and a couple of other variations, but can't get it to accept this cell
reference.
Anyone have the solution?
TIA.
-------------------------
Sub CDO_Mail_Every_Worksheet_File()
Dim iMsg As Object
Dim iConf As Object
Dim ws As Worksheet
Dim wb As Workbook
Dim WBname As String
Dim Flds As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"SMTP.va.gov"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") =
25
.Update
End With
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("A3").Value Like "?*@?*.?*" Then
ws.Copy
Set wb = ActiveWorkbook
WBname = "C:/Personal/" & ws.Name & ".xls"
wb.SaveAs WBname
wb.Close False
Set wb = Nothing
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("A3").Value
.CC = ThisWorkbook.Sheets(1).Range("F27").Value
.From = """Ken Hudson"" <[email protected]>"
.Subject = "FCP User Validation for " & ws.Name
.AddAttachment WBname
.TextBody = ThisWorkbook.Sheets(1).Range("A30")
.Send
End With
Set iMsg = Nothing
Kill WBname
End If
Next ws
Set iConf = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub