Este código foi escrito para que estiver usando o Outlook como seu programa de e-mail.
Este código enviará a planilha recém-criada (cópia do seu Activeworkbook). Guardará o zip na pasta de trabalho antes de enviá-lo com um carimbo de data | hora. Depois que o arquivo zip for enviado, o arquivo zip e a pasta de trabalho serão excluídos.
Sub Zip_Mail_ActiveWorkbook()
Dim strDate As String, DefPath As String, strbody As String
Dim oApp As Object, OutApp As Object, OutMail As Object
Dim FileNameZip, FileNameXls
Dim FileExtStr As String
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xl* and zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
Else
Select Case ActiveWorkbook.FileFormat
Case 51: FileExtStr = ".xlsx"
Case 52: FileExtStr = ".xlsm"
Case 56: FileExtStr = ".xls"
Case 50: FileExtStr = ".xlsb"
Case Else: FileExtStr = "notknown"
End Select
If FileExtStr = "notknown" Then
MsgBox "Sorry unknown file format"
Exit Sub
End If
End If
strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Create the mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = strbody
.Attachments.Add FileNameZip
.Send 'or use .Display
End With
On Error GoTo 0
'Delete the temporary Excel file and Zip file you send
Kill FileNameZip
Kill FileNameXls
Else
MsgBox "FileNameZip or/and FileNameXls exist"
End If
End Sub
#A&A #PIECEOFCAKE #POC #VBA #RondeBruin #MS #Excel
- MS Excel - Zipando - Abra uma Janela e Escolha os Arquivos que deseja Compacatar
- MS Excel - Zipando - Escolha uma Pasta e Compacte Tudo Nela
- MS Excel - Zipando - Compacte Todos os Arquivos Contidos na Pasta Informada no Código
- MS Excel - Zipando - Compactando a Planilha Atual
- MS Excel - Zipando - Compactando e Enviando por e-Mail
Consulte-nos
⬛◼◾▪ CONTATO ▪◾◼⬛
Nenhum comentário:
Postar um comentário