Solved: Copy EXCEL Cell To E-Mail Subject

[NYCAnalyst]

Hi,

I am trying to copy a cell from an excel file I attached and paste it into the subject of the e-mail.

For example, right now the macro below makes the subject "Date - ", where I want it to be "Date - 10/08/2008". Where 10/08/2008 comes from the attached file: "C:\File.xls", sheet "Sheet1", cell A1.

How do I do this?

This is the code I have so far.

Thanks.

I am using Excel / Outlook 2003.


Sub Send_File()
Dim msg As Outlook.MailItem
Set msg = Application.CreateItem(olMailItem)
msg.Subject = "Date - "
msg.To = JoeSchmoe@aol.com
msg.CC = JaneDoe@gmail.com
msg.Body = "This is the message body."
msg.Attachments.Add "C:\File.xls"
msg.Display
End Sub

[JKwan]

This will read cell A1 for that date that you are after.

' Need to Reference Microsoft ActiveX Data Object 2.x
Private Function GetExcelConnection(ByVal Path As String, _
Optional ByVal Headers As Boolean = True) As Connection
Dim strConn As String
Dim objConn As ADODB.Connection
Set objConn = New ADODB.Connection
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Path & ";" & _
"Extended Properties=""Excel 8.0;HDR=" & _
IIf(Headers, "Yes", "No") & """"
objConn.Open strConn
Set GetExcelConnection = objConn
End Function
Sub test()
Dim objRS As ADODB.Recordset
Dim strConn As String
Dim objConn As ADODB.Connection
Dim SubjectDate As Date
'To read a sheet:
' strRequest = "SELECT * FROM Sheet1$"

'To refer to a range by its address:
' strRequest = "SELECT * FROM [Sheet1$A1:D10]"
'To refer to a single-cell range, pretend it's a multi-cell range
'and specify both the top-left and bottom-right cells:
strRequest = "SELECT * FROM [Sheet1$A1:A1]"

'To read a named range:
' strRequest = "SELECT * FROM MyDataRange"

'To read a worksheet-level named range
' strRequest = "SELECT * FROM [Sheet1$MyData]"
Set objConn = GetExcelConnection("c:\test.xls", False)
'and then just open a recordset
Set objRS = objConn.Execute(strRequest)
objRS.MoveFirst
Do While Not objRS.EOF
SubjectDate = objRS.Fields(0).Value
MsgBox SubjectDate
objRS.MoveNext
Loop
Set objRS = Nothing
Set objConn = Nothing
End Sub




msg.Subject = "Date - " & SubjectDate

[NYCAnalyst]

This will read cell A1 for that date that you are after.

' Need to Reference Microsoft ActiveX Data Object 2.x
Private Function GetExcelConnection(ByVal Path As String, _
Optional ByVal Headers As Boolean = True) As Connection
Dim strConn As String
Dim objConn As ADODB.Connection
Set objConn = New ADODB.Connection
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Path & ";" & _
"Extended Properties=""Excel 8.0;HDR=" & _
IIf(Headers, "Yes", "No") & """"
objConn.Open strConn
Set GetExcelConnection = objConn
End Function
Sub test()
Dim objRS As ADODB.Recordset
Dim strConn As String
Dim objConn As ADODB.Connection
Dim SubjectDate As Date
'To read a sheet:
' strRequest = "SELECT * FROM Sheet1$"

'To refer to a range by its address:
' strRequest = "SELECT * FROM [Sheet1$A1:D10]"
'To refer to a single-cell range, pretend it's a multi-cell range
'and specify both the top-left and bottom-right cells:
strRequest = "SELECT * FROM [Sheet1$A1:A1]"

'To read a named range:
' strRequest = "SELECT * FROM MyDataRange"

'To read a worksheet-level named range
' strRequest = "SELECT * FROM [Sheet1$MyData]"
Set objConn = GetExcelConnection("c:\test.xls", False)
'and then just open a recordset
Set objRS = objConn.Execute(strRequest)
objRS.MoveFirst
Do While Not objRS.EOF
SubjectDate = objRS.Fields(0).Value
MsgBox SubjectDate
objRS.MoveNext
Loop
Set objRS = Nothing
Set objConn = Nothing
End Sub




msg.Subject = "Date - " & SubjectDate


Thanks. Haven't tried it yet. Quick question: I have multiple files that need this functionality - do I need to create seperate GetExcelConnection() macros in each module, or can I just put it in the "ThisOutlookSession" object?

[JKwan]

Sub test()
Dim objRS As ADODB.Recordset
Dim strConn As String
Dim objConn As ADODB.Connection
Dim SubjectDate As Date
Dim Index As Long
Dim Files() As Variant
Files = Array("c:\test.xls", "c:\test2.xls")
'To read a sheet:
' strRequest = "SELECT * FROM Sheet1$"

'To refer to a range by its address:
' strRequest = "SELECT * FROM [Sheet1$A1:D10]"
'To refer to a single-cell range, pretend it's a multi-cell range
'and specify both the top-left and bottom-right cells:
strRequest = "SELECT * FROM [Sheet1$A1:A1]"

'To read a named range:
' strRequest = "SELECT * FROM MyDataRange"

'To read a worksheet-level named range
' strRequest = "SELECT * FROM [Sheet1$MyData]"
For Index = LBound(Files) To UBound(Files)
Set objConn = GetExcelConnection(Files(Index), False)
'and then just open a recordset
Set objRS = objConn.Execute(strRequest)
objRS.MoveFirst
Do While Not objRS.EOF
SubjectDate = objRS.Fields(0).Value
MsgBox SubjectDate
objRS.MoveNext
Loop
Set objRS = Nothing
Set objConn = Nothing
Next Index
End Sub



With a slight change to the TEST subroutine, you can pickup your data with one shot. Basically, put in your list of files into your array and then step it thru and output the content of A1

[NYCAnalyst]

Sub test()
Dim objRS As ADODB.Recordset
Dim strConn As String
Dim objConn As ADODB.Connection
Dim SubjectDate As Date
Dim Index As Long
Dim Files() As Variant
Files = Array("c:\test.xls", "c:\test2.xls")
'To read a sheet:
' strRequest = "SELECT * FROM Sheet1$"

'To refer to a range by its address:
' strRequest = "SELECT * FROM [Sheet1$A1:D10]"
'To refer to a single-cell range, pretend it's a multi-cell range
'and specify both the top-left and bottom-right cells:
strRequest = "SELECT * FROM [Sheet1$A1:A1]"

'To read a named range:
' strRequest = "SELECT * FROM MyDataRange"

'To read a worksheet-level named range
' strRequest = "SELECT * FROM [Sheet1$MyData]"
For Index = LBound(Files) To UBound(Files)
Set objConn = GetExcelConnection(Files(Index), False)
'and then just open a recordset
Set objRS = objConn.Execute(strRequest)
objRS.MoveFirst
Do While Not objRS.EOF
SubjectDate = objRS.Fields(0).Value
MsgBox SubjectDate
objRS.MoveNext
Loop
Set objRS = Nothing
Set objConn = Nothing
Next Index
End Sub



With a slight change to the TEST subroutine, you can pickup your data with one shot. Basically, put in your list of files into your array and then step it thru and output the content of A1

What if some of my files are picking up from different cells? (Text1.xls picks up from A1, Test2 picks up from B4, etc). The cells all have the same value though, so would I just use your original code and just pick it all up from Test1.xls?

If I did this, then Test1.xls would not be attached in all of my e-mails. It would be Test2.xls, etc. Is this a problem? Does the file have to be attached?

Also, the cell I am picking up is a date value. How does this get formatted in Outlook? How would I change the formatting if I wanted to? (In excel I would just use TEXT(A1, "mm-dd-yyyy"). Thanks again.

[JKwan]

If I were you, I would use the second set of codes and just read the first value to get your date. In the For loop, only read the file if Index = 0, then you can attach the files to your email - if that is your intent. Otherwise, scrap the For loop and use Files(0) and get the data from your Excel file.
To get the right date format, after you read cell A1 into SubjectDate, just use the Format on it.

[NYCAnalyst]

If I were you, I would use the second set of codes and just read the first value to get your date. In the For loop, only read the file if Index = 0, then you can attach the files to your email - if that is your intent. Otherwise, scrap the For loop and use Files(0) and get the data from your Excel file.
To get the right date format, after you read cell A1 into SubjectDate, just use the Format on it.

I put the GetExcelConnection() Method in object "ThisOutlookSession", and this is what I get:

http://i36.tinypic.com/10yeuj6.jpg

[JKwan]

Did you add reference to Microsoft ActiveX Data Object 2.x?

[NYCAnalyst]

Did you add reference to Microsoft ActiveX Data Object 2.x?

Which one? I show many. (2.8? It looks like it's the most recent).

http://i35.tinypic.com/5d5ap5.jpg

[JKwan]

Yes, use 2.8

[NYCAnalyst]

Yes, use 2.8

Doesn't work. Instead of putting the date in the email subject, a message box pops up with the date:

http://i34.tinypic.com/2qsaotz.jpg

I put the Add_Date (Formerly Test()) function and the GetExcelConnection function in its own module.

Sub Send_Report()
Dim msg As Outlook.MailItem
Set msg = Application.CreateItem(olMailItem)
Add_Date
msg.Subject = "Date: " & strRequest
msg.To = "Joe@aol.com"
msg.CC = "Bob@gmail.com"
msg.Display
End Sub

[JKwan]

I just showed you how to read the Excel and get the data that you required. Now, put the code together and you will have your subject line.

[NYCAnalyst]

I just showed you how to read the Excel and get the data that you required. Now, put the code together and you will have your subject line.

Ok I figured it out. Thanks! =]

(I had to create a module in the excel file and paste this code in there, that way I can do it from Excel, not Outlook)


Sub Send_Mail()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email@email.com"
.CC = "Email2@email.com"
.BCC = ""
.Subject = "Date: " & Sheets("Sheet1").Range("F1").Value
.Body = "Contact me with questions."
.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
'.Send 'or use .Display
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function