none
Macro Salvar RRS feed

  • Pergunta

  • Olá

    Tenho esse código que salva a área de impressão como JPG e gostaria de fazer captação automática de nome range G5 e com inclusão de data e aba para escolher onde salvar

    Sub SalvarImagemJPG()
    
    Dim sFilePath As String
    Dim sView As String
    
    'Captura a janela atual
    sView = ActiveWindow.View
    
    'Define a visualização atual como normal, de forma que não haja sobreposições de "Página X" na imagem
    ActiveWindow.View = xlNormalView
    
    'Desativar temporariamente a atualização da tela
    Application.ScreenUpdating = False
    
    Set Sheet = ActiveSheet
    
    'Digite sua senha
    Sheet.Unprotect "DIGITE AQUI SUA SENHA"
    
    'Defina o caminho do arquivo para exportar a imagem para a área de trabalho do usuário
    sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".jpg"
    
    'Exportar área de impressão como imagem PNG corretamente dimensionada
    zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
    Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
    area.CopyPicture xlPrinter
    Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
    chartobj.Chart.Paste
    chartobj.Chart.Export sFilePath, "jpg"
    chartobj.Delete
    
    'Retorna para a visualização anterior
    ActiveWindow.View = sView
    
    'Reativa a atualização da tela
    Application.ScreenUpdating = True
    
    'Informa ao usuário que o arquivo foi gerado com sucesso e onde o mesmo foi salvo
    MsgBox ("Arquivo Gerado com Sucesso! Local:" & Chr(10) & Chr(10) & sFilePath)
    
    'Digite sua senha
    Sheet.Protect "DIGITE AQUI SUA SENHA"
    
    End Sub
    

    terça-feira, 20 de agosto de 2019 20:20

Todas as Respostas

  • BárbaraBettanin,

       Por favor, veja se é isso...

       1 - Para captar o nome, usei:

    sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & Range("G5").Text & varData & ".jpg"

       2 - Para incluir a data, usei:

    varData = InputBox("Insira uma data", "DATA", Format(Now, "yyyymmddhhnnss"))

       3 - E para escolher a pasta, usei:

    Dim CaixaDialogo As FileDialog
    Set CaixaDialogo = Application.FileDialog(msoFileDialogFolderPicker)
    
    With CaixaDialogo
       .InitialFileName = "C:\"
       .Show
    End With

        Agora precisa ajustar mais o código. O código completo ficou assim:

    Sub SalvarImagemJPG()
    
    Dim sFilePath As String
    Dim sView As String
    
    'Captura a janela atual
    sView = ActiveWindow.View
    
    'Define a visualização atual como normal, de forma que não haja sobreposições de "Página X" na imagem
    ActiveWindow.View = xlNormalView
    
    'Desativar temporariamente a atualização da tela
    Application.ScreenUpdating = False
    
    Set Sheet = ActiveSheet
    
    'Digite sua senha
    Sheet.Unprotect "DIGITE AQUI SUA SENHA"
    
    'Nessa forma temos INPUTBOX como função :
    varData = InputBox("Insira uma data", "DATA", Format(Now, "yyyymmddhhnnss"))
    
    'retirar caracteres especiais do "varData", caso existam...
    
    'Defina o caminho do arquivo para exportar a imagem para a área de trabalho do usuário
    'sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & ActiveSheet.Name & ".jpg"
    sFilePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & Range("G5").Text & varData & ".jpg"
    
    Dim CaixaDialogo As FileDialog
    Set CaixaDialogo = Application.FileDialog(msoFileDialogFolderPicker)
    
    With CaixaDialogo
       .InitialFileName = "C:\"
       .Show
    End With
    
    sFilePath = CaixaDialogo.SelectedItems(1)
    
    'Exportar área de impressão como imagem PNG corretamente dimensionada
    zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
    
    Worksheets(ActiveSheet.Name).PageSetup.PrintArea = "$A$1:$G$5"
    
    Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
    area.CopyPicture xlPrinter
    Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
    chartobj.Chart.Paste
    chartobj.Chart.Export sFilePath, "jpg"
    chartobj.Delete
    
    'Retorna para a visualização anterior
    ActiveWindow.View = sView
    
    'Reativa a atualização da tela
    Application.ScreenUpdating = True
    
    'Informa ao usuário que o arquivo foi gerado com sucesso e onde o mesmo foi salvo
    MsgBox ("Arquivo Gerado com Sucesso! Local:" & Chr(10) & Chr(10) & sFilePath)
    
    'Digite sua senha
    Sheet.Protect "DIGITE AQUI SUA SENHA"
    
    End Sub

        Veja também:

    ===========================================
    VBA FileDialog – Opening, Selecting and Saving files and folders

    https://analystcave.com/vba-application-filedialog-select-file/
    ===========================================
    Como Usar Inputbox no Excel Vba

    http://excelevba.com.br/inputbox-vba/
    ===========================================
    Exibir Janela Salvar Como e Salvar com VBA

    http://douglasgodoy.com.br/salvar-como-e-salvar-arquivo-com-vba/
    ===========================================
    PageSetup.PrintArea property (Excel)

    https://docs.microsoft.com/en-us/office/vba/api/Excel.PageSetup.PrintArea
    ===========================================
    PageSetup object (Excel)

    https://docs.microsoft.com/en-us/office/vba/api/excel.pagesetup
    ===========================================

    []'s,
    Fabio I.

    quarta-feira, 21 de agosto de 2019 12:59