UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Ms Excel Merge Worksheet Rows With Outlook As Attachment, Office 2010    
 
   
halltribe
post Jul 31 2020, 01:35 PM
Post#1



Posts: 38
Joined: 6-January 04



Dear All,

(Firstly, thank you to Ron De Bruin website https://www.rondebruin.nl/win/s1/outlook/tips.htm and Richard Kusleika for enabling me to get this far with their fantastic code).

I hope that someone can help me with two queries. My objective is to send only the relevant rows from the attached worksheet to the staff member via Outlook as an Excel attachment. (I am using Office 2010 but will be upgrading soon to Office 2016, so would be grateful for any foreseeable issues with my current code).

Sheet2 contains the data that will be emailed. MailInfo contains the list of unique names, with corresponding email addresses.

The code performs a vlookup function by matching the values in column A on the MailInfo worksheet with matching values in column A on Worksheet 2 and creates the excel attachment to be sent with the Outlook message.

I need help with two issues:

1. When I run the code, the first email produced does not contain the "body text" of the email. The signature and Excel attachment are present and correct. Subsequent messages are complete with body text, signature and attachment.

2. I would like to CC the line manager of the staff member when I send the emails.

I would be extremely grateful for any guidance. I have spent many hours trying to accomplish this but have not been able to quite complete the task.

My code is pasted below and I have attached the macro-enabled workbook.

Sub Send_Row_Or_Rows_Attachment_1()
'Working in 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim strbody As String
Dim SigString As String
Dim Signature As String

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

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

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:M" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount

'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:C" & _
Worksheets("Mailinfo").Rows.Count), 2, False)

On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set NewWB = Workbooks.Add(xlWBATWorksheet)

rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "" & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)

With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next

'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Mysig.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next

With OutMail
.to = mailAddress
.cc = ThisWorkbook.Sheets("Sheet1").Range("C1").Value
.Subject = "Declarations of Interest Annual Refresh"
.Attachments.Add NewWB.FullName
.HTMLBody = strbody & "<br>" & Signature

strbody = "<p style='font-family:Arial;font-size:17'>" & "Dear staff member" & _
"<br><br>In line with our statutory requirements, we conduct an annual review of Declarations of Interest for all staff." & _
"<br><br>Attached you will find your most recent declarations. Please examine this spreadsheet, make any required amendments and add any new interests." & _
"<br><br>Following this, please ensure that this is reviewed and agreed with your line manager and then returned to corporategovernance@mycompany.net" & _
"<br><br>Further guidance on conflicts of interest and how to complete the form can be found in the attached staff guidance pdf file." & _
"If you have any additional questions, please do not hesitate to contact the Corporate Governance Team on the email address above." & _
"<br><br>Kind regards" & "</p>"

.Display 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

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

Function GetBoiler(ByVal sFile As String) As String
'Richard Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function


Attached File(s)
Attached File  DOI_Email1_2020_21.zip ( 31.39K )Number of downloads: 1
 
Go to the top of the page
 
June7
post Jul 31 2020, 02:04 PM
Post#2



Posts: 1,610
Joined: 25-January 16
From: The Great Land


In future, please post code between CODE tags to retain indentation and readability. You might still be able to edit your post.

Have you step debugged?

--------------------
Attachments Manager is below the edit post window. To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.
Go to the top of the page
 
halltribe
post Jul 31 2020, 02:52 PM
Post#3



Posts: 38
Joined: 6-January 04



Apologies about the layout. When I pasted the code, there was indentation, but appears left aligned on the web page. I do not seem to have an option to edit it.

I have run compile and debug only. There are no errors reported in the code in the VBA Editor, nor when the emails are produced.

Only the first email produced has the missing body text. All other emails are fine. The attachments contain the correct data in all cases. I can probably insert a dummy line of data in the worksheet to overcome this problem, but am keen to understand the concepts in more detail.
Go to the top of the page
 
June7
post Jul 31 2020, 03:09 PM
Post#4



Posts: 1,610
Joined: 25-January 16
From: The Great Land


Step debugging reveals that HTMLBody is set before populating strBody. Move .HTMLBody = strbody & "<br>" & Signature to after strBody=


--------------------
Attachments Manager is below the edit post window. To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.
Go to the top of the page
 
halltribe
post Jul 31 2020, 03:15 PM
Post#5



Posts: 38
Joined: 6-January 04



Perfect. Thank you so much June7.

If anyone can help me with the CC to the line manager I would be grateful.
Go to the top of the page
 
June7
post Jul 31 2020, 03:36 PM
Post#6



Posts: 1,610
Joined: 25-January 16
From: The Great Land


Maybe do another VLookup.
CODE
                        .cc = Application.WorksheetFunction. _
                                VLookup(Cws.Cells(Rnum, 1).Value, _
                                Worksheets("Sheet1").Range("A1:M" & _
                                Worksheets("Sheet1").Rows.Count), 13, False)

--------------------
Attachments Manager is below the edit post window. To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.
Go to the top of the page
 
halltribe
post Jul 31 2020, 07:10 PM
Post#7



Posts: 38
Joined: 6-January 04



Thank you once again June 7.

I added the following code and it worked perfectly.

CODE
Dim LMmailAddress As String

    'Look for the LMmail address in the MailInfo worksheet
            LMmailAddress = Application.WorksheetFunction. _
                    VLookup(Cws.Cells(Rnum, 1).Value, _
                         Worksheets("Sheet2").Range("A1:M" & _
                                Worksheets("Sheet2").Rows.Count), 13, False)

.cc = LMmailAddress
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    5th August 2020 - 04:58 AM