Send a word document as Attachment and Include Subject from the Document

[fredlo2010]

Hello,

I am trying to create a Macro to send a word document as an attachment.

I used the code provided in this place (http://www.howto-outlook.com/howto/senddocasmail.htm) and I am trying to modify it a little to fit my needs.

I need to create variables for the subject that will change with every single document. The problem is that the email come up with only one variable and not the second.

For example the subject should be: "Customer Reference" and it shows as "Customer" ran through the code (F5) and the variable is taking the correct value.

This is the code I am using



Sub SendDocAsMail()


Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem


On Error Resume Next


'Start Outlook if it isn't running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If


'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)




'Display the message


Dim companyName As String
Dim refNumber As String
Dim varsub3 As String


'SET THE COMPANY NAME
ActiveDocument.Tables(1).Columns(2).Cells(1).Range.Select
companyName = Selection.Paragraphs(2).Range


'SET THE REFERENCE NUMBER NAME
refNumber = ActiveDocument.Tables(1).Columns(1).Cells(1).Range






oItem.Subject = companyName & refNumber
oItem.Display


'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing


End Sub


Thanks a lot for the Help :)

[Doug Robbins]

Use


Dim strSubject As String
Dim rngCompany As Range, rngRef As Range
With ActiveDocument.Tables(1)
Set rngCompany = .Cell(1, 2).Range
Set rngRef = .Cell(1, 1).Range
End With
rngCompany.End = rngCompany.End - 1 'strip of end of cell marker
rngRef.End = rngRef.End - 1
strSubject = rngCompany.Text & rngRef.Text
oItem.Subject = strSubject
etc.

[fredlo2010]

Thanks for the help Doug,

I tried it and I kept having the same problem, it only includes one of the variables. Also I forgot to mention that the cells have multiple paragraphs and I need to point to the information in the second paragraph in column 2.

I have attached a copy of the document with some dummy text to make it clearer 10464

This is the code I am using:


Sub SendDocAsMail()

Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem

On Error Resume Next

'Start Outlook if it isn't running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If

'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)

'>>>>>>>>> MODIFICATION SUGGESTED BY DOUG
Dim strSubject As String
Dim rngCompany As Range, rngRef As Range
With ActiveDocument.Tables(1)
Set rngCompany = .Cell(1, 2).Range
Set rngRef = .Cell(1, 1).Range
End With
rngCompany.End = rngCompany.End - 1 'strip of end of cell marker
rngRef.End = rngRef.End - 1
strSubject = rngCompany.Text & rngRef.Text
oItem.Subject = strSubject
'>>>>>>>>> MODIFICATION SUGGESTED BY DOUG END


oItem.Display

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing

End Sub

Thanks for the help.

[Doug Robbins]

The multiple paragraphs will certainly stop it working because you cannot insert a carriage return in a Subject line.

The following will give you what you want:


Dim strSubject As String
Dim rngCompany As Range, rngRef As Range
With ActiveDocument.Tables(1)
Set rngCompany = .Cell(1, 2).Range.Paragraphs(2).Range
Set rngRef = .Cell(1, 1).Range.Paragraphs(1).Range
End With
rngCompany.End = rngCompany.End - 1
rngRef.End = rngRef.End - 1
strSubject = Chr(34) & rngCompany.Text & Chr(34) & " " & Chr(34) & rngRef.Text & Chr(34)
oItem.Subject = strSubject


If you do not need the quotes around the Company Name and Reference number, omit the Chr(34) and the associated ampersand.

[fredlo2010]

Doug,

Thanks a lot for the help this work like a charm. I learned a little about ranges in work vba. Hopefully I will apply it in upcoming projects. This is my final code.

PS: I removed the quotations because I did not need them. Also I switched to late binding because it would case me issues, people using different versions of words.


Sub SendDocAsMail()

Dim oOutlookApp As Object
Dim oItem As Object
Dim strSubject As String
Dim rngCompany As Range
Dim rngRef As Range




On Error Resume Next


'Start Outlook if it isn't running
Set oOutlookApp = CreateObject("Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If


'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)


'>>>>>>>>> MODIFICATION SUGGESTED BY DOUG<<<<<<<<<<<<<
'http://www.vbaexpress.com/forum/showthread.php?47186-Send-a-word-document-as-Attachment-and-Include-Subject-from-the-Document


With ActiveDocument.Tables(1)
Set rngCompany = .Cell(1, 2).Range.Paragraphs(2).Range
Set rngRef = .Cell(1, 1).Range.Paragraphs(1).Range
End With


rngCompany.End = rngCompany.End - 1
rngRef.End = rngRef.End - 1
strSubject = rngCompany.Text & " " & rngRef.Text
oItem.Subject = strSubject
'>>>>>>>>> MODIFICATION SUGGESTED BY DOUG END
oItem.htmlbody = "<b>Offer</b>"
oItem.Display


'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing


End Sub