Ir para conteúdo
Fórum Script Brasil
  • 0

Problema para gerar PDF e enviar e-mail


ACVA

Pergunta

Olá! Desenvolvi um relatório a ser enviado para investidores e automatizei o envio, conforme código abaixo. A questão é que ao executar a macro, o arquivo é gerado e salvo corretamente, aí tento gerar o arquivo novamente e ocorre um erro, que foi tratado. Mas aí, tento gerar o arquivo uma terceira vez e o arquivo é gerado. Algumas vezes tentei gerar o arquivo e ocorreu o conflito, aí apaguei o arquivo da pasta e tentei gerar novamente e o erro permaneceu, mesmo não tendo um arquivo com o mesmo nome na pasta de destino.

Cheguei a conclusão que é uma questão de tempo do refresh do windows. Até coloquei uma macro para executar o refresh antes de gerar e salvar o arquivo e funcionou, mas gerou um outro conflito. Gostaria de ajuda para ajustar a macro de forma que ao encontrar um arquivo na pasta de destino com o mesmo nome, fosse exibida uma mensagem informando sobre o arquivo e pedindo para remover da pasta. E se não encontrar um arquivo com o mesmo nome, o arquivo PDF fosse gerado e depois fosse exibida uma mensagem informando que foi gerado com sucesso.

Seguem abaixo todos os códigos:

CRIA O PDF

Sub Gerar_PDF_Simples()

On Error GoTo msgerro

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim endereco As String

endereco = Planilha14.Range("T2").Text

Sheets(Array("1 - CAPA", "2 - Resumo Executivo", "3 - Resumo de Obras", "4 - Resumo de Vendas")).Select
    Sheets("1 - CAPA").Activate
    
   ' Call subRefreshDesktop
    
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=endereco, Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

        MsgBox "Arquivo gerado com sucesso! Verifique na pasta definida."

Sheets("NAVEGAÇÃO").Select
Range("A1").Select

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

   Exit Sub

msgerro:
    
   MsgBox "já existe um arquivo com o mesmo nome na pasta. Caso queira salvar um novo arquivo, remova o antigo da pasta."

    Sheets("NAVEGAÇÃO").Select
    Range("A1").Select
    
    Application.ScreenUpdating = True
    
    Exit Sub

End Sub

 

EXECUTA O REFRESH DO WINDOWS

Public Sub subRefreshDesktop()

 Dim WSHShell As Object
 Set WSHShell = CreateObject("WScript.Shell")
 WSHShell.AppActivate "Program Manager"
WSHShell.SendKeys "{F5}"
Set WSHShell = Nothing

End Sub

 

CRIA E ENVIA O E-MAIL

Sub enviar_email()

Set appoutk = CreateObject("Outlook.Application")
Set mailoutk = appoutk.CreateItem(olmailitem)

Dim anexo As String
Dim texto As String

anexo = Planilha14.Range("T2").Value & ".pdf"
texto = Planilha20.Range("B22").Value & Chr(10) & Chr(10) & Planilha20.Range("B23") & Chr(10) & Chr(10)

With mailoutk
    .display
    .To = Planilha14.Range("R2").Value
    .CC = ""
    .BCC = ""
    .Subject = Planilha14.Range("R3").Value
    .body = texto & mailoutk.body 'Assinatura 'bodyhtml 'Format(mailoutk.body, "html")
    .Attachments.Add (anexo)
    .Importance = olImportanceHigh
    '.Send

End With

Set mailoutk = Nothing
Set appoutk = Nothing

End Sub
 

Link para o comentário
Compartilhar em outros sites

1 resposta a esta questão

Posts Recomendados

Participe da discussão

Você pode postar agora e se registrar depois. Se você já tem uma conta, acesse agora para postar com sua conta.

Visitante
Responder esta pergunta...

×   Você colou conteúdo com formatação.   Remover formatação

  Apenas 75 emoticons são permitidos.

×   Seu link foi incorporado automaticamente.   Exibir como um link em vez disso

×   Seu conteúdo anterior foi restaurado.   Limpar Editor

×   Você não pode colar imagens diretamente. Carregar ou inserir imagens do URL.



  • Estatísticas dos Fóruns

    • Tópicos
      152,3k
    • Posts
      652,3k
×
×
  • Criar Novo...