Excel Copiar arquivo com extensão variável e salvar cópia em PDF com VBA

[Flávia de Oliveira Batista]

Bom dia, colegas!

Estou com mais uma dificuldade no trabalho que estou fazendo.

Uma dúvida que eu tinha já foi sanada por um de nossos amigos aqui no clube. Eu tinha que pegar um arquivo que foi selecionado pelo usuário, e salvar este arquivo em um pasta padrão. o @Basole me passou o código abaixo e funcionou perfeitamente.

Dim strPathOrigem As String
Dim strPathDest As String

strPathOrigem = txtCaminhoArquivo ' [caixa ao lado que contem caminho completo do arquivo]

strPathDest = "S:\Comum\Administrativo\MEMÓRIA TÉCNICA - STAFF GFO\DADOS\" & ABA & "\" & VBA.Mid(strPathOrigem, VBA.InStrRev(strPathOrigem, "\") + 1, 999)

VBA.FileCopy strPathOrigem, strPathDest

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

 

Mas tenho agora outra questão:

Gostaria de salvar também uma cópia em PDF, pra isso estou usando o caminho:

strPathDest = "S:\Comum\Administrativo\MEMÓRIA TÉCNICA - STAFF GFO\DADOS\" & ABA & "\" & VBA.Mid(strPathOrigem, VBA.InStrRev(strPathOrigem, "\") + 1, 999) & ".pdf"

 

 A cópia é feita normalmente, salvando o arquivo em PDF... o problema é que na hora de abrir esse arquivo salvo com novo formato.. o adobe dá um erro:

 

Alguém sabe me dizer como faço pra resolver esse problema?? Não sei se tem a ver com a programação em si ou outra limitação qualquer do adobe ou do vba...

eu já tentei tirar manualmente a extensão original do arquivo que fica no nome, mas ainda sim não abriu...

 

Desde já gradeço a ajuda.

[Pallan]

da uma olhada se este tópico te ajuda.

Não sei se é obrigatório definir, mas veja no código que foi definido o tipo de saída "ExportAsFixedFormat Type:=xlTypePDF"

 

[Flávia de Oliveira Batista]

@Pallan  

Eu ja tinha visto esse tipo de código que você colocou o link.. Mas acho que esse tipo de salvamento só é utilizado quando o arquivo que precisa ser salvo eh em extensão excel.

Já tentei usar o "ExportAsFixedFormat Type:=xlTypePDF" mas deu erro parece que ele é aplicado em pastas. desse jeito (como mostrado no tópico) :   ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ThisWorkbook.Path & "\" & Nome & ".pdf" 

[Basole]

@Flávia de Oliveira Batista está havendo algum erro no momento de salvar o arquivo me pdf.

 

Repare na msg de erro do adobe que o nome do arquivo esta com duas extensões VRshowtell1R.txt.PDF

 

 

Seria bom se pudesse disponibilizar sua planilha ou um modelo bem próximo, para analisarmos.

[Flávia de Oliveira Batista]

@basole  como faço pra anexar a planilha? nao estou conseguindo.. parece que o formato dela não carrega aqui. a minha planilha é do tipo: "planilha habilitada para macros no office excel xlsm"..

[Basole]

Você precisa zipar (compactar) o arquivo.

Ou faça upload do arquivo no site por exemplo: http://ge.tt e coloque o link aqui.

[Flávia de Oliveira Batista]

@Basole , está aí o arquivo.

O problema do salvamento em PDF que comentei... É na programação do formulário (CADASTRO).

As partes do código estão com comentários pra facilitar a leitura.

 

O código que estou enviando está um pouco enxugado, eu retirei uma parte pra facilitar, mas o que retire não interfere. O que está dando erro é a parte de salvar em PDF, como disse.. o PDF salvo não abre =\

 

 

Só um adendo... li a pouco algo sobre extensões e formatos de arquivos.. 

Entendi que se eu mudo somente a extensão do arquivo  (tirar doc e colocar pdf, por exemplo) ele pode se tornar inutilizável, como está acontecendo, pois quando "salvo em PDF" apenas tiro a extensão original do nome do arquivo e coloco ".pdf" mudando assim a extensão... 

Mas para o arquivo abrir corretamente seria necessário não só mudar a extensão, mas também o formato do arquivo.

 

Ai fiquei mais sem saber ainda kkkk

porque não sei se dá pra fazer isso via VBA.

BANCO DE DADOS TÉCNICO - flávia batista.zip

 

Fui no windows explorer e ativei a visualização das extensões de arquivos. ai tentei mudar a extensão de um doc e apareceu a mensagem:

 

 

Eu não sei se é uma solução possível: o usuário selecionar um arquivo qualquer. ai o VBA abre esse arquivo usa a ferramenta "salvar como" ai salva na pasta padrão e com formato pdf...

[Basole]

@Flávia de Oliveira Batista não se pode simplesmente alterar a extensão do arquivo e esperar que ele fique legível para a nova extensão.

 

No caso do arquivo Word (*.doc), uma opção, seria, a macro abrir o documento e salvar como *.pdf ou *.txt,

Outra opção Importar os dados para dentro de uma aba do Excel, e salvar como *.pdf ou *.txt.

 

[Flávia de Oliveira Batista]

 

@Basole

eu preciso salvar arquivos de word, excel e power point em PDF. a programação já está identificando a extensão dos arquivos quando o usuário seleciona o mesmo. é possível fazer uma macro para abrir o arquivo e usar o "salvar como" para esses tipos de arquivos?

[Basole]

1 hora atrás, Flávia de Oliveira Batista disse:

. . . . . é possível fazer uma macro para abrir o arquivo e usar o "salvar como" para esses tipos de arquivos?

 

Sim, é possível. 

 

Veja este exemplo com um arquivo do word.

 

    Dim oDoc As Object
    Dim apDoc As Object
    Dim PastaDest As String
    Dim NomeArq As String
    
    Set oDoc = CreateObject("Word.Application")
    Set apDoc = oDoc.Documents.Open("C:\users\USUARIO\Documents\NOME_DO_ARQUIVO_WORD.docx")
    
    PastaDestino = "C:\temp\Pasta_PDF\"
    NomeArq = "Teste_Salvar_Doc_p_PDF"
   
    oDoc.ActiveDocument.ExportAsFixedFormat _
    OutputFileName:=PastaDestino & NomeArq & ".pdf", _
    ExportFormat:=17
    
    apDoc.Close SaveChanges:=False
    oDoc.Quit
    Set oDoc = Nothing
    Set apDoc = Nothing

 

[Flávia de Oliveira Batista]

@Basole  *--* 

Funcionou perfeitamente..

pra estender para os outros formatos (apresentação e planilha), posso fazer somente as alteraçoes abaixo, ou seria necessário mais algum comando?

 

"Word.Application" para "PowerPoint.Application" ou "Excel.Application"

 

oDoc.Documents.Open para oDoc.Presentation.Open ou oDoc.Workbook.Open

 

oDoc.ActiveDocument para oDoc.ActivePresentation ou oDoc.ActiveWorkbook

 

 

[Basole]

@Flávia de Oliveira Batista alem dessas alterações que citou, tem mais algumas diferenças que devem ser ajustadas, para cada aplicativo:

 

Exemplo do PowerPoint:

 

    Dim oPPT As Object
    Dim apPPT As Object
    Dim PastaDest As String
    Dim NomeArq As String
    
    Set oPPT = CreateObject("PowerPoint.Application")
    Set apPPT = oPPT.Presentations.Open("C:\users\USUARIO\Documents\NOME_DO_ARQUIVO_POWERPOINT.pptx")
    
    PastaDestino = "C:\temp\Pasta_PDF"
    NomeArq = "Teste_Salvar_PPT_p_PDF"
    
     apPPT.SaveAs Filename:=PastaDestino & NomeArq & ".pdf", FileFormat:=32
    
    apPPT.Close
    oPPT.Quit
    Set oPPT = Nothing
    Set apPPT = Nothing

E agora, o mesmo exemplo adaptado para o Excel:

 

    Dim oXLS As Object
    Dim apXLS As Object
    Dim shXLS As Worksheet
    Dim PastaDest As String
    Dim NomeArq As String
    
    Set oXLS = CreateObject("Excel.Application")
    Set apXLS = oXLS.Workbooks.Open("C:\users\USUARIO\Documents\NOME_DO_ARQUIVO_XLS.xlsx")
    Set shXLS = apXLS.Worksheets(1) 'Define a 1ª aba
    
    PastaDestino = "C:\temp\Pasta_PDF"
    NomeArq = "Teste_Salvar_XLS_p_PDF"
   
     shXLS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PastaDestino & NomeArq & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    apXLS.Close SaveChanges:=False
    Set oXLS = Nothing
    Set apXLS = Nothing

 

[Flávia de Oliveira Batista]

@Basole tem como fazer essa mesma programação pra salvar arquivos em excel?

 

Ai eu limito o salvamento de PDF pra esses 3 formatos.. e se tiver outro formato, salva normal mesmo, sem ser em PDF..

[Basole]

@Flávia de Oliveira Batista eu editei o meu ultimo post e acrescentei para o formato Excel  

[Flávia de Oliveira Batista]

@Basole  

Nossa são muitos comandos diferentes, tem bastante diferença de um pra outro afinal...

Os três deram certinho.

A limitação do caso do excel é que só salva a primeira aba hahah.. mas deu certo também.

 

Vou fazer as adaptações no código aqui.. 

 

Ficou ótimo!

Mais uma vez, muito obrigada pela ajuda!! ^.^

 

 

[Basole]

1 minuto atrás, Flávia de Oliveira Batista disse:

A limitação do caso do excel é que só salva a primeira aba hahah.. mas deu certo também.

 

Não. no exemplo eu defini para 1ª aba => Set shXLS = apXLS.Worksheets(1) 

 

Mas voce pode ajustar para as outas abas 2, 3 , 4, ...etc Set shXLS = apXLS.Worksheets(2)  ou 3, ou 4, etc

 

[Flávia de Oliveira Batista]

31 minutos atrás, Basole disse:

 

Não. no exemplo eu defini para 1ª aba => Set shXLS = apXLS.Worksheets(1) 

 

Mas voce pode ajustar para as outas abas 2, 3 , 4, ...etc Set shXLS = apXLS.Worksheets(2)  ou 3, ou 4, etc

 

 

@Basoleposso usar o comando:

 

N = ThisWorkbook.Sheets.Count

Set shXLS = apXLS.Worksheets(N)

 

Pra sempre saber quantas abas a planilha tem e salvar todas elas..

[Basole]

28 minutos atrás, Flávia de Oliveira Batista disse:

.. . . posso usar o comando:

Para sempre saber quantas abas a planilha tem e salvar todas elas..

 

Para salvar todas as abas em um único arquivo Pdf, eu fiz as alterações necessárias, abaixo:

 

* Mas lembre-se que dependendo as distribuições dos dados em colunas afastadas, quando salvar em pdf, o que ultrapassar no limite da largura das paginas, serão impressas nas linhas abaixo deixando a formatação desconfigurado.      

 

    Dim oXLS As Object
    Dim apXLS As Object
    Dim PastaDest As String
    Dim NomeArq As String
    dim i as integer

    Set oXLS = CreateObject("Excel.Application")
    Set apXLS = oXLS.Workbooks.Open("C:\users\USUARIO\Documents\NOME_DO_ARQUIVO_XLS.xlsx")
 
    '    Seleciona todas as abas:     
    For i = 1 To apXLS.Worksheets.Count
     apXLS.Worksheets(i).Select Replace:=False
    Next i
    
    PastaDestino = "C:\temp\"
    NomeArq = "Teste_Salvar_XLS_p_PDF"

    '     Ajusta para uma pagina
    With apXLS.ActiveSheet.PageSetup
      .FitToPagesWide = 1
      .FitToPagesTall = False
    End With
    
     apXLS.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PastaDestino & NomeArq & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    apXLS.Close SaveChanges:=False
    Set oXLS = Nothing
    Set apXLS = Nothing

 

[Flávia de Oliveira Batista]

@Basole  

Agora está salvando todas as abas, mas tem realmente o problema do tamanho das colunas

 

o comando que voce colocou:

 

 

With apXLS.ActiveSheet.PageSetup
      .FitToPagesWide = 1
      .FitToPagesTall = False
    End With

 

Não seria pra ajustar toas as colunas em uma folha só?... quando gravamos uma macro de impressão ele aparece também como o ajuste de todas as colunas na folha...

Por que nesse caso não funciona?

[Basole]

Em 26/04/2018 às 12:58, Flávia de Oliveira Batista disse:

. . . ...Não seria pra ajustar toas as colunas em uma folha só?... ..

... . . .Por que nesse caso não funciona?

 

@Flávia de Oliveira Batista da forma que estava, ajustava somente a 1ª pagina, por isso que não estava funcionando para todas as paginas do pdf.

 

                                   

 

Com as alterações que fiz todas Planilhas (Abas), são ajustadas para uma pagina.  

 

*Mas quando se tem muitas colunas o Excel automaticamente diminui o zoom, e com isso diminuindo todo o conteúdo, principalmente a fonte.

Sendo assim eu alterei a folha para orientação paisagem para melhorar a visualização, para esses casos.

 

Altere somente este trecho:   

For i = 1 To apXLS.Worksheets.Count
       
          apXLS.Worksheets(i).Visible = xlSheetVisible
          apXLS.Worksheets(i).Select Replace:=False
       
     With apXLS.Worksheets(i).PageSetup
          .Zoom = False
          .FitToPagesWide = 1
          .FitToPagesTall = False
          .Orientation = xlLandscape ' Modo Paissagem
     End With
    
Next i

E desconsidere este trecho abaixo, do código anterior, que já foi incorporado acima: 

 

   

 With apXLS.ActiveSheet.PageSetup
      .FitToPagesWide = 1
      .FitToPagesTall = False
    End With

 

 

 

[Flávia de Oliveira Batista]

@Basole

Todos os códigos funcionaram perfeitamente!!

Obrigada pela atenção e pela ajuda hahah!!

 

Seu conhecimento é fantástico! Parabéns ^.^

[Flávia de Oliveira Batista]

Private Sub ProcuraPersonalizada(ByVal Pesquisa As String)

Dim Busca As Range
Dim Primeiro As String
Dim Resultados, ABA As String

ABA = ComboBox1.Text

   'Executa a busca
    With Worksheets(ABA).Range("A:G")
    
Set Busca = .Find(What:=Pesquisa, AFTER:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
     'Caso tenha encontrado alguma ocorrência...
    If Not Busca Is Nothing Then
      Primeiro = Busca.Address
        Resultados = Busca.Row  'Lista o primeiro resultado na variavel

        'Neste loop, pesquisa todas as próximas ocorrências para
        'o termo pesquisado

        Do
          Set Busca = Cells.FindNext(AFTER:=Busca)
            'Condicional para não listar o primeiro resultado
            'pois já foi listado acima
            If Not Busca.Address Like Primeiro Then
                Resultados = Resultados & ";" & Busca.Row
            End If
       Loop Until Busca.Address Like Primeiro
 
        MatrizResultados = Split(Resultados, ";")
        
     
        'Atualiza dados iniciais no formulário
        SpinButton1.Max = UBound(MatrizResultados)  'Valor maximo do seletor de registros
 
       'habilita o seletor de registro
        SpinButton1.Enabled = True
 
        'indicador do seletor de registros
        Label_Registros_Contador.Caption = "1 de " & UBound(MatrizResultados) + 1
 
        'Resultados encontrados
        
         NOME = Cells(MatrizResultados(0), 4).Value
         strFile = Right(NOME, Len(NOME) - InStrRev(NOME, "\"))
       
        TextBox1.Text = strFile 'nome
        TextBox3.Text = Cells(MatrizResultados(0), 2).Value 'autor
        TextBox4.Text = Cells(MatrizResultados(0), 3).Value 'data
        TextBox5.Text = Cells(MatrizResultados(0), 4).Value 'endereço
        TextBox6.Text = Cells(MatrizResultados(0), 1).Value 'extensão
        
        
      
    Else    'Caso nada tenha sido encontrado, exibe mensagem informativa
 
        SpinButton1.Enabled = False     'desabilita o seletor de registros
        Label_Registros_Contador.Caption = ""   'zera os resultados encontrados
        'limpa os campos do formulário
        TextBox1.Text = ""
        TextBox5.Text = ""
       TextBox3.Text = ""
        TextBox4.Text = ""
       
        MsgBox "Nenhum resultado para '" & Pesquisa & "' foi encontrado."
 

    End If
 End With
 

End Sub

 

@Basole Só mais uma coisa (acho que é a última dúvida) rs ^^

Adaptei um cód de busca pra usar... Uma limitação é que se a "Pesquisa" for encontrada em colunas diferentes da mesma linha, esta linha aparece várias vezes como resultado... se tiver a mesma palavra procurada nas 6 colunas, o mesmo resultado é listado as 6 vezes... 

 

Queria saber se tem como remover essas duplicatas do array de resultados pra que cada resultado aparece somente uma vez.

[Basole]

@Flávia de Oliveira Batista veja agora, com as alterações a variável Resultados só carrega dados distintos obtidos na pesquisa

 

Private Sub ProcuraPersonalizada(ByVal Pesquisa As String)
    Dim Busca As Range
    Dim Primeiro As String
    Dim Resultados, ABA As String
    Dim bNaoExist As Boolean
    Dim dic As Object
    
    ABA = ComboBox1.Text
    
    Set dic = CreateObject("Scripting.Dictionary")
    'Executa a busca
    With Worksheets(ABA).Range("A:G")
        
        Set Busca = .Find(What:=Pesquisa, AFTER:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                                            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        'Caso tenha encontrado alguma ocorrência...
        If Not Busca Is Nothing Then
            Primeiro = Busca.Address
            
            'Neste loop, pesquisa todas as próximas ocorrências para o termo pesquisado
            Do
                'Condicional para não listar o primeiro resultado pois já foi listado acima
                If Not Busca.Address Like Primeira_Ocorrencia Then
                    '  Verifica se já existe na coleção essa ocorncia^:
                    If Not dic.Exists(Busca.Row) Then
                        ' ..  e se não existir adiciona:
                        dic.Add Busca.Row, Value
                        bNaoExist = True
                    End If
                    If bNaoExist Then
                        
                        If Resultados = "" Then
                            Resultados = Busca.Row
                        Else
                            Resultados = Resultados & ";" & Busca.Row
                        End If
                        
                        bNaoExist = False
                    End If
                End If
                
                Set Busca = Cells.FindNext(AFTER:=Busca)
                
                Loop Until Busca.Address Like Primeiro
                
                MatrizResultados = Split(Resultados, ";")
                
                Set dic = Nothing
                Resultados = ""
                'Atualiza dados iniciais no formulário
                SpinButton1.Max = UBound(MatrizResultados)  'Valor maximo do seletor de registros
                
                'habilita o seletor de registro
                SpinButton1.Enabled = True
                
                'indicador do seletor de registros
                Label_Registros_Contador.Caption = "1 de " & UBound(MatrizResultados) + 1
                
                'Resultados encontrados
                
                NOME = Cells(MatrizResultados(0), 4).Value
                strFile = Right(NOME, Len(NOME) - InStrRev(NOME, "\"))
                
                TextBox1.Text = strFile 'nome
                TextBox3.Text = Cells(MatrizResultados(0), 2).Value 'autor
                TextBox4.Text = Cells(MatrizResultados(0), 3).Value 'data
                TextBox5.Text = Cells(MatrizResultados(0), 4).Value 'endereço
                TextBox6.Text = Cells(MatrizResultados(0), 1).Value 'extensão
                
                Else    'Caso nada tenha sido encontrado, exibe mensagem informativa
                    
                    SpinButton1.Enabled = False     'desabilita o seletor de registros
                    Label_Registros_Contador.Caption = ""   'zera os resultados encontrados
                    'limpa os campos do formulário
                    TextBox1.Text = ""
                    TextBox5.Text = ""
                    TextBox3.Text = ""
                    TextBox4.Text = ""
                    
                    MsgBox "Nenhum resultado para '" & Pesquisa & "' foi encontrado."
                    
                End If
                
            End With
            
End Sub

 

[Flávia de Oliveira Batista]

@Basole, funcionou perfeitamente!! Agora só aparecem resultados únicos na pesquisa ^.^  

\o/

 

Mais uma vez obrigada pela ajuda *-*