Ir ao conteúdo
  • Comunicados

    • Gabriel Torres

      Seja um moderador do Clube do Hardware!   12-02-2016

      Prezados membros do Clube do Hardware, Está aberto o processo de seleção de novos moderadores para diversos setores ou áreas do Clube do Hardware. Os requisitos são:   Pelo menos 500 posts e um ano de cadastro; Boa frequência de participação; Ser respeitoso, cordial e educado com os demais membros; Ter bom nível de português; Ter razoável conhecimento da área em que pretende atuar; Saber trabalhar em equipe (com os moderadores, coordenadores e administradores).   Os interessados deverão enviar uma mensagem privada para o usuário @Equipe Clube do Hardware com o título "Candidato a moderador". A mensagem deverá conter respostas às perguntas abaixo:   Qual o seu nome completo? Qual sua data de nascimento? Qual sua formação/profissão? Já atuou como moderador em algo outro fórum, se sim, qual? De forma sucinta, explique o porquê de querer ser moderador do fórum e conte-nos um pouco sobre você.   OBS: Não se trata de função remunerada. Todos que fazem parte do staff são voluntários.
    • DiF

      Poste seus códigos corretamente!   21-05-2016

      Prezados membros do Fórum do Clube do Hardware, O Fórum oferece um recurso chamado CODE, onde o ícone no painel do editor é  <>     O uso deste recurso é  imprescindível para uma melhor leitura, manter a organização, diferenciar de texto comum e principalmente evitar que os compiladores e IDEs acusem erro ao colar um código copiado daqui. Portanto convido-lhes para ler as instruções de como usar este recurso CODE neste tópico:  
Flávia de Oliveira Batista

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

Recommended Posts

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:

image.png.a3886595686a28b0276ef2d8e1415ea1.png

 

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.

Editado por DiF
Botão CODE <>

Compartilhar este post


Link para o post
Compartilhar em outros sites

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"

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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" 

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

image.png.d15a78d4e898c2392b22c8ca0b43b398.png

 

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

Compartilhar este post


Link para o post
Compartilhar em outros sites

Você precisa zipar (compactar) o arquivo.

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

Editado por Basole

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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:

 

image.png.7f8d99057e0d5ae5e218282505639820.png

 

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...

image.png

Editado por Flávia de Oliveira Batista
informação extra

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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.

 

Compartilhar este post


Link para o post
Compartilhar em outros sites

 

@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?

Compartilhar este post


Link para o post
Compartilhar em outros sites
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

 

  • Obrigado 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

Editado por Basole
Acrescentar + informações
  • Obrigado 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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!! ^.^

 

 

  • Curtir 1

Compartilhar este post


Link para o post
Compartilhar em outros sites
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

 

Compartilhar este post


Link para o post
Compartilhar em outros sites
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..

Editado por Flávia de Oliveira Batista

Compartilhar este post


Link para o post
Compartilhar em outros sites
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

 

Editado por Basole
correcoes ortograficas
  • Obrigado 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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?

Editado por DiF

Compartilhar este post


Link para o post
Compartilhar em outros sites
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.

 

                     prtfitpage_1.gif              

 

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

 

 

 

Editado por DiF
acrescentar informações, apenas inserir o code<> em um fragmento de código que estava em negrito.
  • Obrigado 1

Compartilhar este post


Link para o post
Compartilhar em outros sites
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.

Compartilhar este post


Link para o post
Compartilhar em outros sites

@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

 

  • Obrigado 1

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário






Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×