Boas. Muito útil para quem precisa que um ficheiro de excel seja enviado frequentemente por outlook para determinadas pessoas. Cria-se uma tarefa num windows para abrir o ficheiro de excel nos dias que queremos.
Depois abrimos o vba, e no livro incluimos código
Vou dar 3 exemplos:
Neste caso envia o próprio ficheiro.
No caso abaixo envia o ficheiro com outro nome
No exemplo abaixo mostra como copiar uma sheet para um novo ficheiro e enviar
Depois abrimos o vba, e no livro incluimos código
Código:
Private Sub Workbook_Open()
Call Envio_ficheiroOutlook1 'O ficheiro ao abrir é chamada a função. Escolher a que mais convém
End SubVou dar 3 exemplos:
Neste caso envia o próprio ficheiro.
Código:
Sub Envio_ficheiroOutlook1()
'Funciona em Excel 2000-2013
'Este código envia ficheiro com as alterações feitas até ao último "guardar"
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String 'criado para definir todo o texto a colocar no corpo de e-mail
'Uma vbnewline passa para a linha seguinte. 2 vb newline passa para 2 linhas a seguir.
strbody = "Bom dia," & vbNewLine & vbNewLine & _
"Junto envio ficheiro atualizado à data de hoje com o n.º de couves vendidas." & vbNewLine & vbNewLine & _
"Atentamente," & vbNewLine & _
"Zé das Couves"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = """Gerente COuves"" <gerente@agri.xpt>" 'Imaginem que o gerente tem 2 contas de e-mail. Caso não queiram utilizar metam um ' antes do .Sent.. ou apaguem a linha toda
.to = "financeira@agri.xpt" 'Para meterem mais e-mails basta meter ; a seguir ao e-mail e prosseguir inserindo o " no fim para "fechar"
.CC = ""
.BCC = ""
.Subject = "Report diário de vendas"
.Body = strbody 'neste caso está a usar o texto definido na strbody (ver acima). Mas podiam simplesmente meter uma frase entre ""
.Attachments.Add ActiveWorkbook.FullName
'Podem adicionar outros ficheiros. Ver linha abaixo.
'.Attachments.Add ("C:\couves.txt")
.Display ' Aqui usa-se .display para visualizar e depois carregamos em enviar ou se não queremos visualizar, alteramos para .Send - .display tb é usado mt vez para testarmos se vai tudo ok
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End SubNo caso abaixo envia o ficheiro com outro nome
Código:
Sub Envio_ficheiroOutlook2()
'Funciona em Excel 2000-2013
'Copia o ficheiro com outro nome
Dim wb1 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String 'criado para definir todo o texto a colocar no corpo de e-mail
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
'Uma vbnewline passa para a linha seguinte. 2 vb newline passa para 2 linhas a seguir.
strbody = "Bom dia," & vbNewLine & vbNewLine & _
"Junto envio ficheiro atualizado à data de hoje com o n.º de couves vendidas." & vbNewLine & vbNewLine & _
"Atentamente," & vbNewLine & _
"Zé das Couves"
'Fazer uma cópia do ficheiro /Abrir /Enviar e-mail com ficheiro / Apagar ficheiro
TempFilePath = Environ$("temp") & "\"
TempFileName = "Couves Power " & Format(Now, "dd-mmm-yy h-mm-ss") 'Aqui mostra nome de ficheiro definido com data incluida. Se quiserem nome metem apenas "Couves Power"
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = """Gerente COuves"" <gerente@agri.xpt>" 'Imaginem que o gerente tem 2 contas de e-mail. Caso não queiram utilizar metam um ' antes do .Sent.. apaguem a linha toda
.to = "financeira@agri.xpt" 'Para meterem mais e-mails basta meter ; a seguir ao e-mail e prosseguir inserindo o " no fim para "fechar"
.CC = ""
.BCC = ""
.Subject = "Report diário de vendas"
.Body = strbody 'neste caso está a usar o texto definido na strbody (ver acima). Mas podiam simplesmente meter uma frase entre ""
.Attachments.Add ActiveWorkbook.FullName
'Podem adicionar outros ficheiros. Ver linha abaixo.
'.Attachments.Add ("C:\couves.txt")
.Display ' Aqui usa-se .display para visualizar e carregar em enviar ou se não queremos visualizar, alteramos para .Send - .display tb é usado mt vez para testarmos se vai tudo ok
End With
On Error GoTo 0
'Apagar ficheiro
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End SubNo exemplo abaixo mostra como copiar uma sheet para um novo ficheiro e enviar
Código:
Sub Email_Sheet()
'Funciona em Excel 2000-2013
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String 'criado para definir todo o texto a colocar no corpo de e-mail
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Uma vbnewline passa para a linha seguinte. 2 vbnewline passa para 2 linhas a seguir.
strbody = "Bom dia," & vbNewLine & vbNewLine & _
"Junto envio ficheiro atualizado à data de hoje com o n.º de couves vendidas." & vbNewLine & vbNewLine & _
"Atentamente," & vbNewLine & _
"Zé das Couves"
'ActiveSheet.Copy ' Copia a sheet ativa para um novo livro e procede ao envio
Sheets("Vendas").Copy ' Copia a sheet especifica para um novo livro e procede ao envio
Set Destwb = ActiveWorkbook
'Determina a versão de excel e respetiva extenção/formato
With Destwb
If Val(Application.Version) < 12 Then
'Se usas o Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'Se usas Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Copia o conteudo das celulas como valores apenas caso seja pretendido
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Salva novo livro/ Envia livro/Apaga livro
TempFilePath = Environ$("temp") & "\"
TempFileName = "Couves power"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.SentOnBehalfOfName = """Gerente COuves"" <gerente@agri.xpt>" 'Imaginem que o gerente tem 2 contas de e-mail. Caso não queiram utilizar metam um ' antes do .Sent.. apaguem a linha toda
.to = "financeira@agri.xpt" 'Para meterem mais e-mails basta meter ; a seguir ao e-mail e prosseguir inserindo o " no fim para "fechar"
.CC = ""
.BCC = ""
.Subject = "Report diário de vendas"
.Body = strbody 'neste caso está a usar o texto definido na strbody (ver acima). Mas podiam simplesmente meter uma frase entre ""
.Attachments.Add ActiveWorkbook.FullName
'Podem adicionar outros ficheiros. Ver linha abaixo.
'.Attachments.Add ("C:\couves.txt")
.Display ' Aqui usa-se .display para visualizar e carregar em enviar ou se não queremos visualizar, alteramos para .Send - .display tb é usado mt vez para testarmos se vai tudo ok
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Apaga ficheiro que enviaste
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub