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