Jump to content
Fórum Script Brasil
  • 0

Problema para gerar PDF e enviar e-mail


Question

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 to post
Share on other sites

1 answer to this question

Recommended Posts

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Answer this question...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Cloud Computing


  • Forum Statistics

    • Total Topics
      148681
    • Total Posts
      644506
×
×
  • Create New...