Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Macro de Envio
 
Notifications
Clear all

Macro de Envio

 
2024 - VBA & Macros
Post Recente por fazerbem 9 anos atrás
4 Posts
2 Usuários
0 Reactions
685 Visualizações
RSS
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

desculpe, sei que vao rir, mas fiz aqui um salseiro nesta outra Macro. Alguem pode me ajudar?

Na verdade quero escolher a conta que sera usado o envio do email, mas esta parando nesta linha:

.SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)

Sub A5_Pedido_Leader()

Dim NovoArquivoXLS As Workbook
Dim sPlanAEnviar As String
Dim sExcluirAnexoTemporario As String

  Dim OlMensagem As Outlook.MailItem

    Dim OlApp As Outlook.Application

    Dim contaEmail As String
    Dim idEmail As Integer




Worksheets("(P) " & Range("J6")).Unprotect "861485"

   ActiveSheet.Shapes.Range(Array("Picture 3")).Select
     Selection.Delete

Worksheets("(P) " & Range("J6")).Protect "861485"

'Define a Planilha que será enviada por Email. Ex: Plan1, Plan2, Pedidos, etc
 sPlanAEnviar = "(P) " & Range("J6") '(P) " & [J6]
 
 
'Cria um novo arquivo Excel
 Set NovoArquivoXLS = Application.Workbooks.Add
 
 'Copia a Planilha para o novo arquivo criado
 ThisWorkbook.Sheets(sPlanAEnviar).Copy Before:=NovoArquivoXLS.Sheets(1)
 
'Salva o Arquivo
 NovoArquivoXLS.SaveAs ThisWorkbook.Path & "" & sPlanAEnviar & ".xLs"
sExcluirAnexoTemporario = NovoArquivoXLS.FullName

      contaEmail = ThisWorkbook.Sheets("(P) Marinho Nutrition").Range("AI23").Value
      
      
     Set OlApp = CreateObject("Outlook.Application")
Set OlMensagem = OlApp.CreateItem(0)
      

   'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
    For w = 1 To OlApp.Session.Accounts.Count
        If OlApp.Session.Accounts.Item(w).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
            If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & "    ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
                            
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
                
            Else
                 Sheets(Estado).Visible = False
                 Sheets(Loja).Select
                
                GoTo Fim 'Senão sai da rotina
            End If
        End If
    Next


     With OlMensagem

'       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)

'Envia o email
NovoArquivoXLS.SendMail "amigolojista@gmail.com", "Pedido " & [AJ1] & " - " & "(P)" & Range("J6")




  Set OlApp = Nothing



'Fecha o Arquivo Novo
NovoArquivoXLS.Close

'Exclui o arquivo criado apenas para ser enviado
Kill sExcluirAnexoTemporario

Worksheets("(P) " & Range("J6")).Protect "861485"

    
    With ActiveWorkbook.Sheets("(P) " & Range("J6")).Tab
        .Color = 65535
        .TintAndShade = 0
    End With
    
'-----------------------------------------------------------------------------

    Dim nome
    nome = ("(P) " & Range("J6"))
    Dim Ws1     As Worksheet
    Dim Ws2     As Worksheet
    Dim Dest    As Range

    Sheets("LANCAR COMISSAO LEADER").Visible = True
    Sheets("COMISSAO LEADER").Visible = True
        
    Sheets("LANCAR COMISSAO LEADER").Select
    Sheets(nome).Select
    
 '    Sheets("RESUMO").Visible = True
    

'---------------------------------------------------------------------------
'                  4- Salva a comissao em "LANCAR COMISSAO
    
    Range("J6").Select
    Set Ws2 = Sheets("LANCAR COMISSAO LEADER") 'Referencia a guia LANÇAR COMISSAO como Ws2
    Set Dest = Ws2.Range("B3").Range("B103").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
    Range("AP2:AW2").Copy  'Copia o intervalo AI6:AQ6 da guia Resumo
    Dest.PasteSpecial xlPasteValues                                  'Cola valores na guia Comissão
    Application.CutCopyMode = False                                  'Desativaj o clipboard

    Set Ws1 = Sheets(nome)
    'MsgBox Ws1.Name
    Ws1.Select

'---------------------------------------------------------------------------
'                 5- Salva a comissao em "COMISSAO" e "VENDAS"

    Range("J6").Select
    Set Ws2 = Sheets("COMISSAO LEADER") 'Referencia a guia LANÇAR COMISSAO como Ws2
    Set Dest = Ws2.Range("B3").Range("B1000").End(xlUp).Offset(1, -1) 'Encontra a ultima linha da guia comissão (definida como Dest)
    Range("AP2:AW2").Copy  'Copia o intervalo
    Dest.PasteSpecial xlPasteValues                                  'Cola valores na guia Comissão
    Application.CutCopyMode = False                                  'Desativaj o clipboard


    Sheets("LANCAR COMISSAO LEADER").Visible = False
    Sheets("COMISSAO LEADER").Visible = False

GoTo Fim

   End With

    Exit Sub
Fim:



End Sub
 
Postado : 22/03/2016 4:34 pm
 MPrudencio
(@mprudencio)
Posts: 2749
Famed Member
 

Mas onde vc alterou que passou a dar erro?

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 22/03/2016 5:54 pm
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

Refiz o codigo, com a ajuda de outras macros que aqui tenho, fiz os testes e ok, porem a conta que quero que o email seja enviado, nao esta sendo a correta, pois esta enviando pela conta padrao do Outlook, quero que a conta de envio seja a que estiver na celula " AI28 ".

segue o codigo e a planilha

Grato se puder mais esta vez ajudar o amigo aqui.

Andre

Sub A6_Leader()
' Macro Usada para Solicitacao de Frete ou Envio de Pedido


Dim nome
nome = Range("AH31")


Dim sPlanAEnviar As String
Dim OlMensagem As Outlook.MailItem
Dim OlApp As Outlook.Application
Dim contaEmail As String
Dim idEmail As Integer


Dim oOutlook As Object
Dim oEmail As Object
Dim wbAtual As Workbook
Dim sNomeArquivo As String
Dim sLocalTemp As String
Dim resultado  As VbMsgBoxResult
Dim Status      As String
Status = Range("AI23").Value ' Da Planilha Pedido Leader (nome)

Application.ScreenUpdating = False
Set oOutlook = CreateObject("Outlook.Application")
Set oEmail = oOutlook.CreateItem(0)
sLocalTemp = "C:UsersAndreDesktop"

' Copia a planilha ativa e salva em local temporário
ActiveSheet.Copy
Set wbAtual = ActiveWorkbook

' Aqui você define qual planilha deve ser gravada
sNomeArquivo = wbAtual.Worksheets(nome).Name

On Error Resume Next
Kill sLocalTemp & sNomeArquivo
On Error GoTo 0
wbAtual.SaveAs Filename:=sLocalTemp & sNomeArquivo
'---------------------------------------------------------------

contaEmail = ThisWorkbook.Sheets(nome).Range("AI28").Value

    Set OlApp = CreateObject("Outlook.Application")
    Set OlMensagem = OlApp.CreateItem(0)


   'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
    For w = 1 To OlApp.Session.Accounts.Count
                            
                idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
    Next


    With OlMensagem

       .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)

  Set OlApp = Nothing



With oEmail
    .To = "amigolojista@gmail.com"
    
'-------------------------------------------------------------------------------
'Aqui será escolhido se o Envio é uma Solicitação de Frete ou Pedido !
    
If Status = "CONSULTAR" Then
    
    .Subject = "Consulta " & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue um possível pedido para ser consultado a análise de crédito. Favor conferir se batem os valores apresentados, formas de pagamento. Favor tambem na parte inferior do pedido analisar as Observações. Aguardo apuração para informar ao cliente e assim poder liberar este pedido"

Else
    .Subject = "Pedido Aprovado" & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue o Pedido Aprovado. Favor se atente a parte inferior do pedido quanto as Observações. Aguardo a confirmação deste Pedido e informações previstas da entrega"
    
End If
    
    .Attachments.Add wbAtual.FullName
    
    
'---------------------------------------------------------------------------------
 
    .ReadReceiptRequested = True ' confirmação de leitura

'---------------------------------------------------------------------------------

resultado = MsgBox("Deseja ver o Envio e Adicionar um anexo( SIM ) ou ( NÃO ) ?", vbYesNo, "Tomando uma Decisão")
        
If resultado = vbYes Then
    .Display
 Else
    .Send
End If


wbAtual.ChangeFileAccess Mode:=xlReadOnly
Kill wbAtual.FullName
wbAtual.Close SaveChanges:=False

Set oEmail = Nothing
Set oOutlook = Nothing


'-------------------------------------------
'-------------------------------------------
End With
End With

GoTo Fim
Fim:


End Sub
 
Postado : 23/03/2016 11:42 am
 fazerbem
(@fazerbem)
Posts: 697
Honorable Member
Topic starter
 

Quebrei aqui a cabeça e resolvi

Grato a todos, mas desta vez consegui sozinho.

Se faltar algo, com certeza corro aqui.

Sub A6_Leader()

Dim OlMensagem As Outlook.MailItem
Dim OlApp As Outlook.Application
Dim contaEmail As String
Dim idEmail As Integer
Dim oOutlook As Object
'                 Dim oEmail As Object
Dim wbAtual As Workbook
Dim sNomeArquivo As String
Dim sLocalTemp As String
Dim resultado  As VbMsgBoxResult
Dim Status      As String
Status = Range("AI23").Value ' Da Planilha Pedido Leader (nome)
Dim nome
nome = Range("AH31")

Application.ScreenUpdating = False
Set oOutlook = CreateObject("Outlook.Application")
'  Set oEmail = oOutlook.CreateItem(0)
Set oMensagem = oOutlook.CreateItem(0)
sLocalTemp = "C:UsersAndreDesktop"

' Copia a planilha ativa e salva em local temporário
ActiveSheet.Copy
Set wbAtual = ActiveWorkbook

' Aqui você define qual planilha deve ser gravada
sNomeArquivo = wbAtual.Worksheets(nome).Name

On Error Resume Next
Kill sLocalTemp & sNomeArquivo
On Error GoTo 0
wbAtual.SaveAs Filename:=sLocalTemp & sNomeArquivo
'---------------------------------------------------------------

contaEmail = ThisWorkbook.Sheets(nome).Range("AI28").Value

    'Create the Outlook application and the empty email.
    Set OlApp = CreateObject("Outlook.Application")
  Set OlMensagem = OlApp.CreateItem(0)

   'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
    For w = 1 To OlApp.Session.Accounts.Count


  If OlApp.Session.Accounts.Item(w).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
           
    idEmail = w 'Define o id da conta para o comando enviar
                Exit For 'Sai do laço
                
           Else
            End If

    Next

'Using the email, add multiple recipients, using a list of addresses in column C.
  With OlMensagem
  
    .Display
    .SendUsingAccount = OlApp.Session.Accounts.Item(idEmail)
    .To = "amigolojista@gmail.com"
    
'-------------------------------------------------------------------------------
'Aqui será escolhido se o Envio é uma Solicitação de Frete ou Pedido !
    
If Status = "CONSULTAR" Then
    
    .Subject = "Consulta " & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue um possível pedido para ser consultado a análise de crédito. Favor conferir se batem os valores apresentados, formas de pagamento. Favor tambem na parte inferior do pedido analisar as Observações. Aguardo apuração para informar ao cliente e assim poder liberar este pedido"

Else
    .Subject = "Pedido Aprovado" & [AJ1].Value & " - " & [J6].Value
    .Body = "Segue o Pedido Aprovado. Favor se atente a parte inferior do pedido quanto as Observações. Aguardo a confirmação deste Pedido e informações previstas da entrega"
    
End If
    
    .Attachments.Add wbAtual.FullName
        
'---------------------------------------------------------------------------------
 
    .ReadReceiptRequested = True ' confirmação de leitura

'---------------------------------------------------------------------------------

resultado = MsgBox("Deseja ver o Envio e Adicionar um anexo( SIM ) ou ( NÃO ) ?", vbYesNo, "Tomando uma Decisão")
        
If resultado = vbYes Then
    .Display
 Else
    .Send
End If

wbAtual.ChangeFileAccess Mode:=xlReadOnly
Kill wbAtual.FullName
wbAtual.Close SaveChanges:=False


Set oOutlook = Nothing

End With


End Sub
 
Postado : 23/03/2016 3:57 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico