How can I make a PasteSpecial from Excel to Outlook?

[cbaldan]

Hello.

I have a spreadsheet that has the summary of some projects, and is password protect. At the end of the day, I need to people to send it over by e-mail.

I want to have a macro that will unprotect, copy the contents of the spreadsheet, paste Special into a new Outook e-mail as Enhanced Windows Metafile, and reprotect the spreadsheet. So far I found a workaround using a msgbox, but the users still need to make a manual Paste Special.

My issue is that I could not find a way to use the PasteSpecial method alogn the HTMLBody.

Any help is appreciated.

Thanks, Cleber.

Sub copyToClipboard()

Sheets(1).Unprotect Password:="123"

Set myOlApp = CreateObject("Outlook.Application")
Set emailInforme = myOlApp.CreateItem(olMailItem)

emailInforme.Subject = "Informe Diário do Projeto: " & Range("D6").Value & " - " & Range("D7").Value

Cells.Find(What:="##FIM", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 1).Select
Range("A1", ActiveCell).Select
Selection.Copy

emailInforme.Display
'emailInforme.HTMLBody.PasteSpecial (DataFormat = ppPasteEnhancedMetafile)
' The above line doesn't work

MsgBox "Click OK after sending the e-mail"

Range("B2").Select
Range("B2").Value = ""
Sheets(1).Protect Password:="123"

End Sub

[mancubus]

this (other related pages) may help:

http://www.rondebruin.nl/mail/folder1/mail4.htm

[cbaldan]

Hello Mancubus.

I appreciate your help but that wouldn't help. I got 9 test leaders and they need to send the e-mail to different areas of the company.

I got to make it work another way:


Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set OriginalWS = Sheets(1)
OriginalWS.Unprotect Password:="123"

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Cells.Find(What:="##FIM", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 1).Select
Range("A1", ActiveCell).Select
Set rng = Selection.SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

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:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Cells.Select
Selection.Locked = True
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With

Range("B2").Select
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
Sheets(1).Protect Password:="informeisq"

ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = "Insira seus comentários aqui"
.Item.To = "E-Mail_Address_Here"
.Item.Subject = "Informe Diário do Projeto: " & Range("D6").Value & " - " & Range("D7").Value
.Item.Display
End With

OriginalWS.Protect Password:="123"


End Sub