Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Ajuda Como Criar Cópia de Arquivo PDF Automaticamente Excel VBA

Esclarecimentos e dúvidas sob o Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel publicado no site e blog http://www.tomasvasquez.com.br
fdsouza3350
Acabou de chegar
Acabou de chegar
Mensagens: 2
Registrado em: Qua Dez 27, 2017 12:45 pm

Ajuda Como Criar Cópia de Arquivo PDF Automaticamente Excel VBA

Mensagem por fdsouza3350 »

Bom dia meus amigos!
Estou precisando de sua ajuda com uma tarefa!
Tenho um formulário em Excel que armazena algumas informações em uma aba que utilizo como banco de dados, e junto com essas informações preciso anexar o caminho de um arquivo em pdf que é uma evidência documental que o usuário poderá abrir quando necessário.
Para garantir que os anexos (arquivos em pdf) não se percam e estejam organizados em um só lugar criei uma pasta chamada bd_anexos.
Preciso de um código que ao selecionar o arquivo em pdf no PC, automaticamente seja salvo uma cópia deste arquivo na pasta bd_anexos, para que o usuário não precise:

1- abrir a pasta do arquivo a ser anexado,
2- copiar o arquivo a ser anexado,
3- abrir a pasta bd_anexos,
4- colar o arquivo a ser anexado,
5- para então anexar o pdf no formulário.

Segue abaixo o código que utilizo para anexar o caminho do arquivo.

Código: Selecionar todos

Private Sub btn_AnexarPDF_Click()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim local_pdf As String
Dim caminho As String

On Error Resume Next

Application.DisplayAlerts = False

local_pdf = Application.GetOpenFilename(filefilter:="PDF Files,*.pdf")
Me.txt_Localpdf.Text = local_pdf

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
Para auxiliar no entendimento utilizo um código que faz exatamente o que preciso com imagens, o código salva uma cópia da imagem a partir do objeto imagem dentro do formulário, porém não consigo adaptar esta função para o arquivo em pdf.
Segue abaixo o código a que me refiro.

Código: Selecionar todos

Private Sub bto_Imagem_Click()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim strCaminho As String
Dim strNomeImagem As String
Dim separa_pasta As String
Dim parte() As String
Dim descricao As String
Dim local_imagem As String
Dim caminho As String
Dim pasta As Object, NomePasta

On Error Resume Next

Application.DisplayAlerts = False

If Me.txt_NumReg = "" Then
MsgBox ("Informe primeiro um registro para inserir uma foto!")
Exit Sub
End If

local_imagem = Application.GetOpenFilename(filefilter:="Picture Files,*.bmp;*.jpg")
Me.Image1.Picture = LoadPicture("")
Me.Image1.Picture = LoadPicture(local_imagem)
Me.Image1.PictureSizeMode = fmPictureSizeModeStretch

       Set pasta = CreateObject("Scripting.FileSystemObject")
    NomePasta = ActiveWorkbook.Path & "\" & "BD_Imagens"
    
        If Not pasta.FolderExists(NomePasta) Then
        pasta.CreateFolder (NomePasta)
    End If
    
strReg = Me.txt_NumReg.Text

nome_arquivo = "Registro_" & strReg & ".bmp"

Base = NomePasta & "\"

local_arquivo = Base & nome_arquivo

SavePicture Me.Image1.Picture, local_arquivo

Me.txt_LocalImagem = local_arquivo

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
Desde já agradeço pela ajuda.

Grande abraço e sucesso a todos!


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
Reinaldo
Jedi
Jedi
Mensagens: 1537
Registrado em: Sex Ago 01, 2014 4:09 pm
Localização: Garça - SP / SCS - SP

Re: Ajuda Como Criar Cópia de Arquivo PDF Automaticamente Excel VBA

Mensagem por Reinaldo »

Segue uma possibilidade

Código: Selecionar todos

Private Sub btn_AnexarPDF_Click()
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim local_pdf As String, Nome_Pdf As String
Dim caminho As String, NomePasta As String
Dim pasta As Object
Dim StrNome() As String

On Error Resume Next

Application.DisplayAlerts = False
'Verifica se pasta existe, caso não cria pasta bd_anexos
Set pasta = CreateObject("Scripting.FileSystemObject")
NomePasta = ActiveWorkbook.Path & "\" & "bd_anexos"
    If Not pasta.FolderExists(NomePasta) Then pasta.CreateFolder (NomePasta)
'Captura caminho e nome do arquivo pdf
local_pdf = Application.GetOpenFilename(filefilter:="PDF Files,*.pdf")
StrNome = Split(local_pdf, "\")
'Identifica nome do arquivo PDF
Nome_Pdf = StrNome(UBound(StrNome))
'Copia arquivo Pdf para pasta bd_anexos
FileCopy local_pdf, NomePasta & "\" & Nome_Pdf
'Informa na txt nome e local do pdf
Me.txt_Localpdf.Text = NomePasta & "\" & Nome_Pdf

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub


Responder