VBA - XLS object export procedures to PPT

XLS2PPT.cls

Option Explicit
Private PPTApp As PowerPoint.Application
Private PPTPreso As PowerPoint.Presentation
Private PPTPresoReport As PowerPoint.Presentation
Private PPTSlide As PowerPoint.Slide
Private objObjectToExport As Object
Private objNewShape As Object
Private strPresoPath As String
Enum ResizeRescale
    Resize = 1
    Rescale = 2
End Enum
Private Sub Class_Initialize()

Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Visible = True

End Sub
Private Sub Class_Terminate()

PPTApp.Quit

End Sub
Property Let PresoPath(strPath As String)

strPresoPath = strPath

End Property
Sub OpenPresentation()

Set PPTPreso = PPTApp.Presentations.Open(strPresoPath)

End Sub
Sub CreateReport(Optional strSavedPresoPath As String)

If strSavedPresoPath <> "" Then

    Set PPTPresoReport = PPTApp.Presentations.Open(strSavedPresoPath)

Else

    Set PPTPresoReport = PPTApp.Presentations.Add

End If

End Sub
Sub SaveReport(Optional strFileName As String)

If strFileName <> "" Then

    PPTPresoReport.SaveAs strFileName
    
Else

    PPTPresoReport.Save

End If

End Sub
Sub CopySlide(intSlideNo As Integer, Optional intTargetPosition As Integer)

Dim intTargetSlide As Integer

If intTargetPosition = 0 Then
    intTargetSlide = PPTPresoReport.Slides.Count + 1
Else
    intTargetSlide = intTargetPosition
End If

PPTPreso.Slides(intSlideNo).Copy
PPTPresoReport.Slides.Paste Index:=intTargetSlide
PPTPresoReport.Slides.Item(intTargetSlide).Design = PPTPreso.Slides.Item(intSlideNo).Design

End Sub
Sub SaveAndClose()

PPTPreso.Save
PPTPreso.Close

Set PPTPreso = Nothing

End Sub
Sub ChartToExport(strSheetName As String, strChartName As String)

Dim objTemp As Object

If strSheetName = "" Then MsgBox "Sheet name where a chart is places was not provided.": Exit Sub
If strChartName = "" Then MsgBox "Chart name was not provided.": Exit Sub

Set Me.SetObjectToExport = ThisWorkbook.Sheets(strSheetName).ChartObjects(strChartName)

End Sub
Sub PictureToExport(strSheetName As String, strPictureName As String)

Dim objTemp As Object

If strSheetName = "" Then MsgBox "Sheet name where a chart is places was not provided.": Exit Sub
If strPictureName = "" Then MsgBox "Picture name was not provided.": Exit Sub

Set Me.SetObjectToExport = ThisWorkbook.Sheets(strSheetName).Shapes(strPictureName)

End Sub
Sub RangeToExport(strSheetName As String, strRangeName As String)

Dim objTemp As Object

If strSheetName = "" Then MsgBox "Sheet name where a chart is places was not provided.": Exit Sub
If strRangeName = "" Then MsgBox "Range name was not provided.": Exit Sub

Set Me.SetObjectToExport = ThisWorkbook.Sheets(strSheetName).Range(strRangeName)

End Sub
Property Set SetObjectToExport(obj As Object)

Set objObjectToExport = obj

End Property
Sub TransferObject(intType As Integer, intSlideToExport As Integer, dblTop As Double, dblLeft As Double, eResizeRescale As ResizeRescale, dblHeight As Double, dblWidth As Double, Optional strShapeName As String)

'0 - ppPasteDefault
'1 - ppPasteBitmap
'2 - ppPasteEnhancedMetafile
'4 - ppPasteGIF
'8 - ppPasteHTML
'5 - ppPasteJPG
'3 - ppPasteMetafilePicture
'10 - ppPasteOLEObject
'6 - ppPastePNG
'9 - ppPasteRTF
'11 - ppPasteShape
'7 - ppPasteText

With objObjectToExport

    .Parent.Parent.Activate     'activate workbook
    .Parent.Activate            'activate sheet
    .Copy                       'copy ojbect
    
End With

Set objNewShape = PPTPreso.Slides(intSlideToExport).Shapes.PasteSpecial(intType)(1)

objNewShape.Top = dblTop
objNewShape.Left = dblLeft
If strShapeName <> "" Then objNewShape.Name = strShapeName

Select Case eResizeRescale

    Case 1
        objNewShape.Width = dblWidth
        objNewShape.Height = dblHeight
    
    Case 2
        objNewShape.LockAspectRatio = False
        objNewShape.ScaleWidth dblWidth, msoTrue
        objNewShape.ScaleHeight dblHeight, msoTrue

End Select

End Sub
Sub RemoveSlide(intSlideNo As Integer)

PPTPresoReport.Slides(intSlideNo).Delete

End Sub
Sub RemoveShapesFromSlide(intSlideNo As Integer, Optional intShapeType As Integer, Optional varExceptions As Variant)

'msoAutoShape    1   AutoShape.
'msoCallout  2   Callout.
'msoCanvas   20  Canvas.
'msoChart    3   Chart.
'msoComment  4   Comment.
'msoDiagram  21  Diagram.
'msoEmbeddedOLEObject    7   Embedded OLE object.
'msoFormControl  8   Form control.
'msoFreeform 5   Freeform.
'msoGroup    6   Group.
'msoIgxGraphic   24  SmartArt graphic
'msoInk  22  Ink
'msoInkComment   23  Ink comment
'msoLine 9   Line
'msoLinkedOLEObject  10  Linked OLE object
'msoLinkedPicture    11  Linked picture
'msoMedia    16  Media
'msoOLEControlObject 12  OLE control object
'msoPicture  13  Picture
'msoPlaceholder  14  Placeholder
'msoScriptAnchor 18  Script anchor
'msoShapeTypeMixed   -2  Mixed shape type
'msoTable    19  Table
'msoTextBox  17  Text box
'msoTextEffect   15  Text effect

Dim i As Integer

BeginClearing:
If PPTPreso.Slides(intSlideNo).Shapes.Count = 0 Then Exit Sub
If intShapeType = 0 Then

    For i = 1 To PPTPreso.Slides(intSlideNo).Shapes.Count
        If IsArray(varExceptions) Then
            If Not CheckIfInArray(varExceptions, PPTPreso.Slides(intSlideNo).Shapes(i).Name) Then
                PPTPreso.Slides(intSlideNo).Shapes(i).Delete
                GoTo BeginClearing
            End If
        Else
            PPTPreso.Slides(intSlideNo).Shapes(i).Delete
            GoTo BeginClearing
        End If
    Next i
    
Else

    For i = 1 To PPTPreso.Slides(intSlideNo).Shapes.Count
        If PPTPreso.Slides(intSlideNo).Shapes(i).Type = intShapeType Then
            If IsArray(varExceptions) Then
                If Not CheckIfInArray(varExceptions, PPTPreso.Slides(intSlideNo).Shapes(i).Name) Then
                    PPTPreso.Slides(intSlideNo).Shapes(i).Delete
                    GoTo BeginClearing
                End If
            Else
                PPTPreso.Slides(intSlideNo).Shapes(i).Delete
                GoTo BeginClearing
            End If
        End If
    Next i
    
End If

End Sub
Sub InsertTextBox(intSlideToExport As Integer, strShapeName As String, dblLeft As Double, dblTop As Double, dblWidth As Double, dblHeight As Double, dblMargin As Double, blnLineVisible As Boolean, varLineColor As Variant, blnBGVisible As Boolean, varBGColor As Variant, dblBGTransparency As Double, strText As String, strFontName As String, intFontSize As Integer, varFontColor As Variant)

Set PPTSlide = PPTPreso.Slides(intSlideToExport)
With PPTSlide.Shapes.AddShape(msoShapeRectangle, dblLeft, dblTop, dblWidth, dblHeight).TextFrame

    .Parent.Name = strShapeName

    .TextRange.Text = strText
    .MarginBottom = dblMargin
    .MarginLeft = dblMargin
    .MarginRight = dblMargin
    .MarginTop = dblMargin
    
    With .Parent
    
        .Line.Visible = blnLineVisible
        .Line.ForeColor.RGB = RGB(varLineColor(0), varLineColor(1), varLineColor(2))
    
        .Fill.Visible = blnBGVisible
        .Fill.Solid
        .Fill.ForeColor.RGB = RGB(varBGColor(0), varBGColor(1), varBGColor(2))
        .Fill.Transparency = dblBGTransparency
    
    End With
    
    With .TextRange.Font
    
        .Parent.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
        .Parent.Font.Name = strFontName
        .Size = intFontSize
        .Color.RGB = RGB(varFontColor(0), varFontColor(1), varFontColor(2))
    
    End With

End With
Set PPTSlide = Nothing

End Sub
Sub InsertTable(intSlideToExport As Integer, strTableName As String, intNumRows As Integer, intNumCols As Integer, dblLeft As Double, dblTop As Double, dblWidth As Double, dblHeight As Double, varTableBGColor As Variant, varTableBorderColor As Variant)

Dim r As Integer
Dim c As Integer

Set PPTSlide = PPTPreso.Slides(intSlideToExport)
With PPTSlide.Shapes.AddTable(intNumRows, intNumCols, dblLeft, dblTop, dblWidth, dblHeight)

    .Name = strTableName
    .Fill.BackColor.RGB = RGB(100, 0, 0)
    
    For r = 1 To .Table.Rows.Count
        For c = 1 To .Table.Columns.Count
            .Table.Cell(r, c).Shape.Fill.ForeColor.RGB = RGB(varTableBGColor(0), varTableBGColor(1), varTableBGColor(2))
            .Table.Cell(r, c).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(varTableBorderColor(0), varTableBorderColor(1), varTableBorderColor(2))
        Next c
    Next r

End With

Set PPTSlide = Nothing

End Sub
Sub InsertToTableCell(intSlideNo As Integer, strTableName As String, intRowNo As Integer, intColNo As Integer, strValue As String, varBGColor As Variant, strFontName As String, intFontSize As Integer, varFontColor As Variant, blnBold As Boolean, blnUnderline As Boolean, blnItalic As Boolean, Optional dblCellWidth As Double, Optional dblCellHeight As Double)

Dim objTable As Object

Set objTable = PPTPreso.Slides(intSlideNo).Shapes(strTableName).Table

If dblCellWidth <> 0 Then objTable.Columns(intColNo).Width = dblCellWidth
If dblCellHeight <> 0 Then objTable.Rows(intRowNo).Height = dblCellHeight

With objTable.Cell(intRowNo, intColNo)
    
    .Shape.TextFrame.TextRange.Text = strValue
    .Shape.TextFrame.TextRange.Font.Name = strFontName
    .Shape.TextFrame.TextRange.Font.Size = intFontSize
    .Shape.TextFrame.TextRange.Font.Bold = blnBold
    .Shape.TextFrame.TextRange.Font.Italic = blnItalic
    .Shape.TextFrame.TextRange.Font.Underline = blnUnderline
    .Shape.TextFrame.TextRange.Font.Color.RGB = RGB(varFontColor(0), varFontColor(1), varFontColor(2))
    .Shape.Fill.ForeColor.RGB = RGB(varBGColor(0), varBGColor(1), varBGColor(2))
    
End With

End Sub
Sub MergeTableCells(intSlideNo As Integer, strTableName As String, x1, y1, x2, y2)

With PPTPreso.Slides(intSlideNo).Shapes(strTableName).Table

    .Cell(x1, y1).Merge MergeTo:=.Cell(x2, y2)

End With

End Sub
Property Get TableCellTop(intSlideNo As Integer, strTableName As String, x As Integer, y As Integer) As Double
 
With PPTPreso.Slides(intSlideNo).Shapes(strTableName).Table

    TableCellTop = .Cell(x, y).Shape.Top

End With
 
End Property
Property Get TableCellLeft(intSlideNo As Integer, strTableName As String, x As Integer, y As Integer) As Double
 
With PPTPreso.Slides(intSlideNo).Shapes(strTableName).Table

    TableCellLeft = .Cell(x, y).Shape.Left

End With
 
End Property