G

Untitled

public
Guest Jul 10, 2024 Never 13
Clone
Plaintext paste1.txt 78 lines (67 loc) | 2.65 KB
1
Sub EnviarEmailComPlanilha()
2
Dim OutlookApp As Object
3
Dim OutlookMail As Object
4
Dim rng As Range
5
Dim sht As Worksheet
6
Dim strBody As String
7
Dim LastRow As Long
8
9
' Defina a planilha e o intervalo que você deseja copiar
10
Set sht = ThisWorkbook.Sheets("NomeDaSuaPlanilha") ' Substitua pelo nome da sua planilha
11
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row ' Encontra a última linha preenchida na coluna A
12
Set rng = sht.Range("A1:D" & LastRow) ' Ajuste o intervalo conforme necessário
13
14
' Converte o intervalo selecionado em HTML
15
strBody = RngToHTML(rng)
16
17
' Inicia o Outlook e cria um novo e-mail
18
Set OutlookApp = CreateObject("Outlook.Application")
19
Set OutlookMail = OutlookApp.CreateItem(0)
20
21
' Preenche o e-mail
22
With OutlookMail
23
.To = "[email protected]" ' Substitua pelo endereço de e-mail do destinatário
24
.CC = ""
25
.BCC = ""
26
.Subject = "Assunto do Email"
27
.HTMLBody = strBody
28
.Display ' Para exibir o e-mail antes de enviar, use .Display; para enviar diretamente, use .Send
29
End With
30
31
' Limpeza
32
Set OutlookMail = Nothing
33
Set OutlookApp = Nothing
34
End Sub
35
36
Function RngToHTML(rng As Range)
37
' Função para converter o intervalo em HTML
38
Dim fso As Object
39
Dim ts As Object
40
Dim TempFile As String
41
Dim TempWB As Workbook
42
43
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
44
45
' Copia o intervalo para uma nova planilha temporária
46
rng.Copy
47
Set TempWB = Workbooks.Add(1)
48
With TempWB.Sheets(1)
49
.Cells(1, 1).PasteSpecial Paste:=8
50
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
51
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
52
.Cells(1, 1).Select
53
Application.CutCopyMode = False
54
End With
55
56
' Salva a nova planilha como arquivo HTML temporário
57
With TempWB.PublishObjects.Add( _
58
SourceType:=xlSourceRange, _
59
Filename:=TempFile, _
60
Sheet:=TempWB.Sheets(1).Name, _
61
Source:=TempWB.Sheets(1).UsedRange.Address, _
62
HtmlType:=xlHtmlStatic)
63
.Publish (True)
64
End With
65
66
' Lê o arquivo HTML temporário para uma string
67
Set fso = CreateObject("Scripting.FileSystemObject")
68
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
69
RngToHTML = ts.ReadAll
70
ts.Close
71
72
' Limpeza
73
Set ts = Nothing
74
Set fso = Nothing
75
TempWB.Close SaveChanges:=False
76
Set TempWB = Nothing
77
Kill TempFile
78
End Function