Excel VBA - Copie qualquer objeto como imagem e exporte-o


Lembro-me de há alguns, quando criei este Blog específico de VBA, como ainda era incipiente a inter-colaboração de códigos VBA no mercado nacional, bem como a utilização profissional de Dashboards e Scorecards. O desenvolvimento VBA naquela época restringia-se aos expressão "faz-se macros no excel'. Hoje, estamos vivenciando um mercado de desenvolvimento VBA mais maduro, cheio de profissionais competentíssimos (tomara que essa expressão não seja um neologismo), com inúmeras excelentes soluções de desenvolvimento e aplicações de automação. Encontramo-nos amadurecidos e prontos para avançarmos no nosso ciclo de aprimoramento profissional!

You can export a chart to an image file using VBA
Chart to Image Conversion using VBA
Excel Chart to GIF Conversion using VBA
Export Excel Chart to Image using VB
Save Chart as image
Export function of the Chart
To copy a selected Excel chart or range object as a picture
Image File Type Comparison of Exported Charts
Image Export - Org Chart in Excel Worksheet
Best format to export Excel Range to picture
Export Chart as Image: Run-time error 1004
Exporting a Chart(object) EXCEL VBA
Saving a chart as a picture file
Paste Chart from Excel to VBA form
Using VBA to Export Charts as Images in Excel 2007
How can I export a chart as a jpg/tif? in Excel Charting?
How to superimpose chart images or extract data by vba in Excel?
How to convert Excel to jpg, gif image?
How to Export A Picture Or Chart From Excel To Powerpoint?


O artigo a seguir visa elevar a qualidade da nossa entrega. Enviar o conteúdo das nossas soluções para outros ambientes e interfaces. Das aplicações da suíte MS Office, a editores gráficos para a criação de Info Gráficos e até mesmo a inserção destes em páginas da Web de modo automático (Sharepoint). Mas prá que quero isso? Talvez pergunte-se. Abaixo seguem diversos códigos bem elaborados que possibilitarão copiar os gráficos das suas planilhas pré-existentes, bem como os ranges de dados destas (conjuntos de células previamente selecionados) como uma imagem. 

Detalho:
Por vezes desejará não enviar a fonte de dados junto com o gráfico para um Slide que lhe solicitaram.

Talvez deseje enviar uma tabela, um relatório, partes de um Balanced Scorecard, um Dashboards ou um  Scorecards, ou mesmo um conjunto de KPIs, sem que estes sejam alterados por quem recebê-los.

Criar um informativo regular, parte de um relatório, que envia via MS Outlook, comentários dos
relatórios, agregando conteúdo analítico e não apenas gráficos e dados estáticos para o público alvo.

Como fazê-lo?
Com os recursos abaixo alistados, poderá enviar somente as imagens, como se tirasse uma foto e colasse no Slide, num documento MS Word, num e-mail e até mesmo no Photoshop (há!).

Chega! Essas são apenas algumas das possibilidades...Pensem em outras...



CÓDIGO: 
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

Para copiar um gráfico selecionado (ou ativo) em uma planilha, implemente a seguinte sintaxe:


CÓDIGO: 
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Copiando um range de dados, colando-a como uma imagem:


CÓDIGO: 
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Copie gráficos selecionados (ou ativo) em uma planilha, implemente a seguinte sintaxe:


CÓDIGO: 
Worksheets("Nome da pasta").ChartObjects(1).Chart.CopyPictureAppearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

Copie uma faixa de dados específica, embora não esteja selecionada, colando-a a posteriori:
:

CÓDIGO: 
Worksheets("Nome da pasta").Range("B11:AF25").CopyPicture Appearance:=xlScreen, Format:=xlPicture

Pois é, sempre existem códigos admiráveis por aí:


CÓDIGO:
Sub GraficoToPowerPoint()
    Dim objPPT As Object
    Dim objPrs As Object
    Dim shtTemp As Worksheet
    Dim chtTemp As ChartObject
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.presentations.Open ThisWorkbook.Path & "\Dashboard_Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1 'ppViewSlide
     
    For Each shtTemp In ThisWorkbook.Worksheets
        For Each chtTemp In shtTemp.ChartObjects
            intSlide = intSlide + 1
            chtTemp.CopyPicture
            If intSlide > objPPT.presentations(1).Slides.Count Then
                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.presentations(1).Slides.Add(Index:=intSlide, Layout:=1).SlideIndex
            End If
            objPPT.ActiveWindow.View.Paste
        Next
    Next
    objPPT.presentations(1).Save
    objPPT.Quit
     
    Set objPrs = Nothing
    Set objPPT = Nothing
End Sub

Copiando range e gráfico para o MS Powerpoint:


CÓDIGO:
Sub GraficoRange_TO_Powerpoint() 
    Dim objPPT As Object 
    Dim objPrs As Object 
    Dim objSld As Object 
    Dim shtTemp As Object 
    Dim chtTemp As ChartObject 
    Dim objShape As Shape 
    Dim objGShape As Shape 
    Dim intSlide As Integer 
    Dim blnCopy As Boolean 
     
    Set objPPT = CreateObject("Powerpoint.application") 
    objPPT.Visible = True 
    objPPT.Presentations.Add 
    objPPT.ActiveWindow.ViewType = 1
     
    For Each shtTemp In ThisWorkbook.Sheets 
        blnCopy = False 
        If shtTemp.Type = xlWorksheet Then 
            For Each objShape In shtTemp.Shapes
                blnCopy = False 
                If objShape.Type = msoGroup Then 

                    For Each objGShape In objShape.GroupItems 
                        If objGShape.Type = msoChart Then 
                            blnCopy = True 
                            Exit For 
                        End If 
                    Next 
                End If 
                If objShape.Type = msoChart Then blnCopy = True 
                 
                If blnCopy Then 
                    intSlide = intSlide + 1 
                    objShape.CopyPicture 

                    objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                    objPPT.ActiveWindow.View.Paste 
                End If 
            Next 
            If Not blnCopy Then 

                intSlide = intSlide + 1 
                shtTemp.UsedRange.CopyPicture 

                objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
                objPPT.ActiveWindow.View.Paste 
            End If 
        Else 
            intSlide = intSlide + 1 
            shtTemp.CopyPicture 

            objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex 
            objPPT.ActiveWindow.View.Paste 
        End If 
    Next 
     
    Set objPrs = Nothing 
    Set objPPT = Nothing 
End Sub

Bônus:


CÓDIGO: 
Sub RangeUsado_TO_Powerpoint()
    Dim objPPT As Object
    Dim shtTemp As Object
    Dim intSlide As Integer
     
    Set objPPT = CreateObject("Powerpoint.application")
    objPPT.Visible = True
    objPPT.Presentations.Open ThisWorkbook.Path & "\Bernardes.ppt"
    objPPT.ActiveWindow.ViewType = 1
    
    For Each shtTemp In ThisWorkbook.Sheets
        shtTemp.Range("A1", shtTemp.UsedRange).CopyPicture xlScreen, xlPicture
        intSlide = intSlide + 1

        objPPT.ActiveWindow.View.GotoSlide Index:=objPPT.ActivePresentation.Slides.Add(Index:=objPPT.ActivePresentation.Slides.Count + 1, Layout:=12).SlideIndex
        objPPT.ActiveWindow.View.Paste
        With objPPT.ActiveWindow.View.Slide.Shapes(objPPT.ActiveWindow.View.Slide.Shapes.Count)
            .Left = (.Parent.Parent.SlideMaster.Width - .Width) / 2
        End With
    Next
     
    Set objPPT = Nothing
End Sub

Boa diversão!

2 comentários:

diHITT - Notícias