VBA Excel Intermediário - Exportando DOIS Ranges Simultaneamente para o PowerPoint

VBA Excel Intermediário - Exportando DOIS Ranges Simultaneamente para o PowerPoint

Sim, caso nosso Dashboard seja grande demais, ou tenha pequenas partes que gostaria de destacar durante a sua apresentação, talvez decida exportar pequenas partes em slides separados, logo após tê-los exportado juntos.

Ter a liberdade de poder efetuar essa exportação com a mesma funcionalidade técnica é sempre uma bem recebida solução para a nossa correria do dia a dia.

Um plus+ neste código é o que verá no arremate da colagem da imagem, quando o script tenta adequar o tamanho da imagem ao slide onde está sendo colado. 

Começa assim:

    Dim nTitle As String
    Dim nRngName01 As String

    Dim nRngName02 As String

     Let nRngName01 = "TOP"
     Let nRngName02 = "BODY"

     Let nTitle = ActiveSheet.Range("AB9").Value

    Call XPortRng2PPT (nRngName01, nRngName02, nSheetName, nTitle)

Continue assim:

Sub XPortRng2PPT (nRngName01 As String, nRngName02 As String, nSheet As String, nTitle As String)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 01/06/2016 - 10:32
    ' Application: Field Force Dashboard Analysis® 
    '     Purpose: Copy/Paste An Excel Range Into a New PowerPoint Presentation

    Dim ActFileName As Variant
    Dim ScaleFactor As Single

    On Error GoTo ErrorHandling

    Let ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.pptx), *.ppt")
    Let ScaleFactor = Range("myScaleFactor").Value

    Application.Sheets(nSheet).Select

    Set PP = CreateObject("Powerpoint.Application")

    If ActFileName = False Then
        PP.Activate
        PP.Presentations.Add
        Set PP_File = PP.ActivePresentation
    Else
        PP.Activate
        Set PP_File = PP.Presentations.Open(ActFileName)
    End If

    Let PP.Visible = True

    CopyandPastetoPPT nRngName01, nTitle, ScaleFactor, ScaleFactor
    CopyandPastetoPPT nRngName02, nTitle, ScaleFactor, ScaleFactor

    Set PP_Slide = Nothing
    Set PP_File = Nothing
    Set PP = Nothing

    Application.Sheets(nSheet).Activate
Exit Sub

ErrorHandling:

Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing

MsgBox "Error No.: " & Err.Number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error"

End Sub

Sub CopyandPastetoPPT (myRangeName As String, _
                              myTitle As String, _
                              myScaleHeight As Single, _
                              myScaleWidth As Single)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 01/06/2016 - 10:32
    ' Application: Field Force Dashboard Analysis®
    '     Purpose: Copy/Paste.

    Dim NextShape As Integer

    Application.GoTo Reference:=myRangeName

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Range("A1").Select

    PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11

    Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count)
    Let PP_Slide.Shapes.Title.TextFrame.TextRange.Text = myTitle
    Let NextShape = PP_Slide.Shapes.Count + 1

    PP_Slide.Shapes.PasteSpecial 2
    
    PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 1
    PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1
    PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2 - PP_Slide.Shapes(NextShape).Width \ 2
    PP_Slide.Shapes(NextShape).Top = 90

End Sub


Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

VBA Excel Intermediário - Exportando um Range para o PowerPoint

VBA Excel Intermediário - Exportando um Range para o PowerPoint

Exportar um range específico do nosso Dashboard diretamente para o MS Powerpoint deixou de ser um grande segredo e tornou-se a funcionalidade mais usada entre aqueles que conhecem um pouco de VBA. Por isso disponibilizo mais uma versão dessa possibilidade:

Sub ExcelRangeToPowerPoint(nSheet As String, NewPPT As Boolean, nRng As String, nLeft As Integer, nTop As Integer)
    '      Author: André Luiz Bernardes - A&A - In Any Place - andreluizbernardes@gmail.com
    '        Date: 11/05/2016 - 12:25
    ' Application: Field Force Dashboard Analysis®
    '     Purpose: Copy/Paste An Excel Range Into a New PowerPoint Presentation

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
  Set rng = Sheets(nSheet).Range(nRng) 'ThisWorkbook.ActiveSheet.Range(nRng)

'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint não pôde ser aberto, abortando exportação."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position:
      myShape.Left = nLeft
      myShape.Top = nTop

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub



Se gostou, compartilhe este post com outros! Deixe seus comentários e sugestões.

brazilsalesforceeffectiveness@gmail.com

DONUT PROJECT 2014 - VBA - WORD - Exportação Automatizada - De *.docx Para *.pdf - Otimizando o tamanho

Consultancy in Excel, Access, VBA, Dashboards, Scorecards & PowerPoint Projects

DESENVOLVO APLICAÇÕES VBA

Perguntas, Questões e Esclarecimentos

Baixe o Calendário Compacto para 2014 em Excel

Este código, desenvolvido no MS Excel, pode reduzir o tamanho de um documento do Word, por exemplo de 400kb para 100kb.

 Série eBook Donut Projects: 

  

Suponhamos que lhe pedissem alguma forma de reduzir o tamanho de um arquivo *.docx, que inclui algumas fotos. Uma pergunta mais específica seria a de se há algum modo de realmente reduzirmos o tamanho de um documento do MS Word que tenha incorporado imagens *.Jpg? Essa exigência existe devido a necessidade de enviarmos um e-mail com este documento em anexo, pesando menos do que 100 KB. Digamos que a empresa onde trabalha não permita nada acima de 100 KB e por isso tenhamos que descobrir uma maneira de reduzir o tamanho do arquivo. Não há nenhum formato de arquivo especificado ou exigido.

Certamente após refletirmos um pouco, algumas soluções possíveis vieram:

A compactação de arquivos *.Jpeg, salvando-o num formato de arquivo diferente e reinserindo-os no texto.

Capturar um screenshot do documento do MS Word com zoom-out e salvá-lo como um novo arquivo *.Jpg.

Bem, até o momento a melhor solução era realmente fazer screenshots e depois manipulá-los para reduzir o seu tamanho. O único problema era que esse processo seria manual e muito longo, havendo um monte de arquivos para passar.

Após alguns testes com diferentes formatos de arquivo, verificando os resultados (tamanhos). Deparei-me com o recurso de exportação de documento ativo para *.Pdf, mas com a opção de otimização para definir um tamanho mínimo.

Após experimentar isso em cerca de 10 arquivos diferentes, e obter em cada vez, um arquivo menor do que 100 KB de arquivo. Imaginei que seria muito simples abrir um arquivo *.Docx e exportá-lo para um arquivo *.Pdf. Mas ainda imaginava como automatizaria esse processo. Não sabia a quantidade exata de arquivos que precisavam ser convertidos - apenas tinha a impressão de haver muitos deles.

Então, tive a ideia para o processo de automação, criar uma planilha do MS Excel com algumas macros que:

• Solicitasse ao usuário para entrar um ou vários arquivos de uma só vez.

• Abrir cada arquivo.

• Processar cada arquivo (exportação).

• Terminar, formatando as células, colocando os resultados em destaque.

Códigos:

Sub Main()

Let Application.ScreenUpdating = False

    Setup

    SelectFilesToConvert

    UpdateConverted

Columns.AutoFit

Let Application.ScreenUpdating = True

End Sub

Private Sub Setup()

    Cells.Clear

    

Let Range("A1") = "Path"    
Let Range("B1") = "Size (KB)"    
Let Range("D1") = "PDF Path"    
Let Range("E1") = "PDF Size (KB)"

 Let Range("E:E").Font.Color = xlNone

 Let Range("B:B", "E:E").NumberFormat = "0.0"

    With Range("A1:E1")

        Let .Interior.Color = RGB(102, 153, 255)

        Let .Borders.LineStyle = xlContinuous

    End With 

End Sub

Private Sub SelectFilesToConvert()

    Dim i As Long

    Dim r As Range

    Set r = Range("A2")

    With Application.FileDialog(msoFileDialogOpen)

        Let .AllowMultiSelect = True        

        Let .InitialFileName = "initial path"

        Let .InitialView = msoFileDialogViewList

        .Filters.Clear

        .Filters.Add "Word Documents", "*.docx"

        .Show

        ' Create hyperlinks to the files and show their size in KB

        For i = 1 To .SelectedItems.Count

            r.Worksheet.Hyperlinks.Add Anchor:=r, Address:=.SelectedItems(i), TextToDisplay:=.SelectedItems(i)

            r.Offset(0, 1) = FileLen(r) / 1000

            ' Open each Word file

            OpenWordFile CStr(r)

            Set r = r.Offset(1, 0)

        Next i

    End With 

End Sub

Private Sub OpenWordFile(filePath As String) 

    On Error GoTo ErrCleanUp

    Dim wordApp As Word.Application

    Set wordApp = New Word.Application

    Let wordApp.DisplayAlerts = wdAlertsNone

    Let wordApp.Visible = False

    Dim wordDoc As Document

    Set wordDoc = wordApp.Documents.Open(filePath)

    SaveAsMinimizedPDF wordDoc 

    Let wordDoc.Saved = True

    wordDoc.Close

    wordApp.Quit

    Exit Sub

ErrCleanUp:

    Let wordDoc.Saved = True

    wordDoc.Close

    wordApp.Quit

End Sub

Private Sub SaveAsMinimizedPDF(ByRef doc As Document)

    doc.ExportAsFixedFormat OutputFileName:= _

 Split(doc.FullName, ".")(0) & ".pdf", ExportFormat:=wdExportFormatPDF _

 , OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForOnScreen, Range _

 :=wdExportAllDocument, From:=1, to:=1, Item:=wdExportDocumentContent, _

 IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _

 wdExportCreateNoBookmarks, DocStructureTags:=False, BitmapMissingFonts:= _

 False, UseISO19005_1:=False

End Sub

Private Sub UpdateConverted()

    Dim i As Long

    Dim r As Range

    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row

        Set r = Range("A" & i)

        r.Offset(0, 3).Worksheet.Hyperlinks.Add _

 Anchor:=r.Offset(0, 3), Address:=Split(r, ".")(0) & ".pdf", _

 TextToDisplay:=Split(r, ".")(0) & ".pdf"

        r.Offset(0, 4) = FileLen(r.Offset(0, 3)) / 1000

        ' validate

        r.Offset(0, 4).Font.Color = IIf(r.Offset(0, 4) > 100, RGB(255, 0, 0), RGB(0, 255, 0))

    Next i 

End Sub

 Série de Livros nut Project 

  

 Série VBA Outlook: 

  

  

  

 Série DONUT PROJECT 2024 

  

  

  

  

 Série DONUT PROJECT 2021 

  

  

  

 Série DONUT PROJECT 2018 

  

   

  

  

 

 Série DONUT PROJECT 2015 

  

    

   

  

   

  

   

  

 

 Série DONUT PROJECT 2014 

   

   

  

  

    

  Clique aqui e nos contate via What's App para avaliarmos seus projetos 

Envie seus comentários e sugestões e compartilhe este artigo!

brazilsalesforceeffectiveness@gmail.com