Enviar e-mail pelo VBA do excel

[Éverson Cruz]

Ola!!!!

Bom estou com um problema no VBA do Excel, eu preciso criar uma macro que faça uma cópia de uma planilha com outro nome e depois mande por email tudo isso numa rotina do VBA

Obs: eu tenho o outlook Express e Microsoft Office 2002

Eu fiz esta rotina só que esta faltando a rotina em que ela faça uma cópia e mantenha a atual (eu quero mandar somente uma planilha), se alguém puder me ajudar fico grato.

Private Sub CommandButton4_Click()

Dim Recipient As String, Subj As String, HLink As String

Dim Recipientcc As String, Recipientbcc As String

Dim msg As String

Dim arq As String

' AQUI ENVIA O E-MAIL

Recipient = "[email protected]"

'Recipientcc = "[email protected]"

'Recipientbcc = ""

Subj = "Solicitação de N.F"

msg = "Testando!!!" & vbNewLine & vbNewLine & _

"Favor enviar o nº da NF"

msg = WorksheetFunction.Substitute(msg, vbNewLine, "%0D%0A")

HLink = "mailto:" & Recipient & "?" & "cc=" & Recipientcc _

& "&" & "bcc=" & Recipientbcc & "&"

HLink = HLink & "subject=" & Subj & "&"

HLink = HLink & "body=" & msg

ThisWorkbook.FollowHyperlink (HLink)

'Aqui anexa o arquivo e envia o email

With Application

.Wait (Now + TimeValue("0:00:01"))

.SendKeys "%i", Wait = True

.SendKeys "~", Wait = True

.SendKeys "C:\Documents and Settings\Meus documentos" & arq & ".xls", Wait = True

.SendKeys "~", Wait = True

.SendKeys "%s", Wait = True

End With

[apaesleme]

Ola!!!!

Bom estou com um problema no VBA do Excel, eu preciso criar uma macro que faça uma cópia de uma planilha com outro nome e depois mande por email tudo isso numa rotina do VBA

Obs: eu tenho o outlook Express e Microsoft Office 2002

Eu fiz esta rotina só que esta faltando a rotina em que ela faça uma cópia e mantenha a atual (eu quero mandar somente uma planilha), se alguém puder me ajudar fico grato.

Private Sub CommandButton4_Click()

Dim Recipient As String, Subj As String, HLink As String

Dim Recipientcc As String, Recipientbcc As String

Dim msg As String

Dim arq As String

' AQUI ENVIA O E-MAIL

Recipient = "[email protected]"

'Recipientcc = "[email protected]"

'Recipientbcc = ""

Subj = "Solicitação de N.F"

msg = "Testando!!!" & vbNewLine & vbNewLine & _

"Favor enviar o nº da NF"

msg = WorksheetFunction.Substitute(msg, vbNewLine, "%0D%0A")

HLink = "mailto:" & Recipient & "?" & "cc=" & Recipientcc _

& "&" & "bcc=" & Recipientbcc & "&"

HLink = HLink & "subject=" & Subj & "&"

HLink = HLink & "body=" & msg

ThisWorkbook.FollowHyperlink (HLink)

'Aqui anexa o arquivo e envia o email

With Application

.Wait (Now + TimeValue("0:00:01"))

.SendKeys "%i", Wait = True

.SendKeys "~", Wait = True

.SendKeys "C:\Documents and Settings\Meus documentos" & arq & ".xls", Wait = True

.SendKeys "~", Wait = True

.SendKeys "%s", Wait = True

End With

OPa, tb estou atras desta resposta você conseguiu...

[tiagonmuniz]

Oi...

Consegui fazer o que você precisa com o seguine codigo... porém ele funcionou algumas vezes e logo apos parou de funcionar.

Se eu duplicar o endereço ele envia, mas ai desconfigura o texto do corpo do e-mail.

 

Mas acho que pode ser util, primeiro ele cria uma planilha nova, cola os dados da plan aberta sem formulas. logo apos ele envia apenas auqlea planilha em aberto para o e-mail cadastrado, no final ele exclui a planilha que foi criada nova, deixando o arquivo como era no inicio...

 

Segue codigo.

 

Sub Enviar_por_e_mail2()

Dim CurrentSheet As Worksheet
' usa os dados da planilha ativa no momento.
Application.ScreenUpdating = False

        'Nome na Planilha Ativa em B16
        nomeB2 = CStr(ActiveSheet.Range("k11").Value)

        ' seleciona a planilha atual.
        Set CurrentSheet = ActiveSheet
        On Error Resume Next

        'copia todas as células da planilha ativa
        CurrentSheet.Cells.Copy

        'Cria a Nova PASTA (ARQUIVO)
        Set ws = Sheets.Add

        'cola somente os valores na planilha Ativa da nova Pasta,
        'sem formulas e mantenndo a formatação
        With ActiveSheet.Range("A1")
          .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
          .PasteSpecial Paste:=xlFormats
        
         
        End With

        Application.CutCopyMode = False
       
       'Define os Novos Nomes - Planilha(ABA) e Pasta(Arquivo)
        novoNome = [K11].Value

        'Renomeia a planilha nova com
        'o Nome que estava em k11
        With ActiveSheet
            .Name = [K11].Value
            .Range("A1").Select
        End With
              
       ' esta macro envia apenas a planilha aberta por e-mail
     Dim OL              As Object
     Dim EmailItem       As Object
     Dim Wb              As Workbook
     Dim FileName        As String
     Dim y               As Long
     Dim TempChar        As String
     Dim SaveName        As String
     
    Application.ScreenUpdating = False
     Set OL = CreateObject("Outlook.Application")
     Set EmailItem = OL.CreateItem(olMailItem)
     FileName = ActiveSheet.Name & " - " & ActiveWorkbook.Name
     For y = 1 To Len(FileName)
         TempChar = Mid(FileName, y, 1)
         Select Case TempChar
         Case Is = "/", "\", "*", "?", """", "<", ">", "|", ":"
         Case Else
             SaveName = SaveName & TempChar
         End Select
     Next y
     ActiveSheet.Copy
     Set Wb = ActiveWorkbook
     Wb.SaveAs SaveName
     Wb.ChangeFileAccess xlReadOnly
     With EmailItem
        .Subject = "LIBERAÇÃO DA EMPRESA Nº_ " & [K11].Value
         .Body = "Com destino " & [g17].Value & vbCrLf & _
         "Placa " & [t16].Value & vbCrLf & _
         "Container " & [k16].Value & vbCrLf & _
         .to = "[email protected]"
         'informar o e-mail do destinatário
         .Importance = olImportanceNormal
         'ou olImprotanceHigh Ou olImprotanceLow para definar o grau de importância
         .Attachments.Add Wb.FullName
         .Send
     End With
     Kill Wb.FullName
     Wb.Close False
     
    Application.ScreenUpdating = True
     
    Set Wb = Nothing
     Set OL = Nothing
     Set EmailItem = Nothing
     
' Excluir_Planilha_atual Macro
'

'
    Sheets("[K11].Value").Select
    ActiveWindow.SelectedSheets.Delete
End Sub