Powerpoint macro loses formatting when adapted to Excel

[blokeyhighlander]

I'm using Excel to generate a powerpoint presentation based on premade slides.

I'm using the following code to do the copying and pasting of the slides: Copy slides with source formatting. I've also tried slides.insertfromfile and some other code I've found all with the same results.

When I use the code from that link in PowerPoint, it works wonderfully. When I use it (with minor modifications) in Excel, it successfully copy/pastes, and the paste initially looks successful, but then powerpoint overrides the text format for each text box to be whatever the first character's format is. For instance, the first line of the copied slide's text box is bolded green and all other lines are unbolded and black, but powerpoint changes ALL of the text to be bolded and green.

Any ideas on how to fix this?

Here's the code that creates a new presentation:

Sub ExcelToNewPowerPoint()    
    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide


    ' Create instance of PowerPoint
    Set PPApp = CreateObject("Powerpoint.Application")


    ' For automation to work, PowerPoint must be visible
    ' (alternatively, other extraordinary measures must be taken)
    PPApp.Visible = True


    ' Create a presentation
    Set PPPres = PPApp.Presentations.Add


    ' Some PowerPoint actions work best in normal slide view
    PPApp.ActiveWindow.ViewType = ppViewNormal


    ' Add first slide to presentation
    Set PPSlide = PPPres.Slides.Add(1, ppLayoutTitleOnly)


    'Count the number of products
    Dim ProductLength As Long
    ProductLength = Range("data").Rows.Count
    
    'Loop through range and add slides
    Dim counter As Integer
    counter = 1
    
    
    Do While counter <= ProductLength
        
    If Range("data")(counter, 1) = True Then
        Call ImportFromPPT("C:\Users\myname\Downloads\Products\" & Range("data")(counter, 5), 1, 1)
        Call FindAndReplace1(Range("data")(counter, 6), Range("data")(counter, 7))
    
    End If
    
    counter = counter + 1
    
    Loop
    
    PPPres.Slides.InsertFromFile _
    "C:\Users\myname\Downloads\Products\Pricing.ppt", PPPres.Slides.Count
    
    'Loop through range and add slides
    Dim counter2 As Integer
    Dim sPrice As String
    counter2 = 1
    
    Do While counter2 <= ProductLength
        
    If Range("data")(counter2, 1) = True Then
        
    sPrice = sPrice & Range("data")(counter2, 3) & Chr(13)
    
    End If
    
    counter2 = counter2 + 1
    
    Loop
    
    PPPres.Slides(PPPres.Slides.Count).Shapes(2).TextFrame.TextRange.text = sPrice
    
    Call FindAndReplace1("XPRICEX", Range("total")(1, 1))
    


    ' Save and close presentation
    With PPPres
        .SaveAs "C:\Users\myname\Downloads\Proposals\" & Range("Rep")(1, 1) & "\" & Range("Advertiser")(1, 1) & " " & Format(Now, "dd-mmm-yy h.mm.ss") & ".pptx"
        .Close
    End With


    ' Quit PowerPoint
    PPApp.Quit


    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing


End Sub

here's the modified code from the link

Private Sub ImportFromPPT(FileName As String, SlideFrom As Long, SlideTo As Long)Dim SrcPPT As Presentation, SrcSld As Slide, Idx As Long, SldCnt As Long


    Set PPApp = GetObject(, "Powerpoint.Application")
    Set PPPres = PPApp.ActivePresentation
    
    Set SrcPPT = PPApp.Presentations.Open(FileName, , , msoFalse)
    SldCnt = SrcPPT.Slides.Count


    If SlideFrom > SldCnt Then Exit Sub
    If SlideTo > SldCnt Then SlideTo = SldCnt


    For Idx = SlideFrom To SlideTo Step 1
        Set SrcSld = SrcPPT.Slides(Idx)
        SrcSld.Copy
        With PPPres.Slides.Paste
            .Design = SrcSld.Design
            .ColorScheme = SrcSld.ColorScheme
            ' if slide is not following its master (design, color scheme)
            ' we must collect all bits & pieces from the slide itself


            ' >>>>>>>>>>>>>>>>>>>>


            If SrcSld.FollowMasterBackground = False Then
                .FollowMasterBackground = False
                .Background.Fill.Visible = SrcSld.Background.Fill.Visible
                .Background.Fill.ForeColor = SrcSld.Background.Fill.ForeColor
                .Background.Fill.BackColor = SrcSld.Background.Fill.BackColor


                ' inspect the FillType object
                Select Case SrcSld.Background.Fill.Type
                    Case Is = msoFillTextured
                        Select Case SrcSld.Background.Fill.TextureType
                        Case Is = msoTexturePreset
                            .Background.Fill.PresetTextured (SrcSld.Background.Fill.PresetTexture)
                        Case Is = msoTextureUserDefined
                        ' TextureName gives a filename w/o path
                        ' not implemented, see picture handling
                        End Select


                    Case Is = msoFillSolid
                        .Background.Fill.Transparency = 0#
                        .Background.Fill.Solid


                    Case Is = msoFillPicture
                        ' picture cannot be copied directly, need to export and re-import slide image
                        If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = False
                        bMasterShapes = SrcSld.DisplayMasterShapes
                        SrcSld.DisplayMasterShapes = False
                        SrcSld.Export SrcPPT.path & SrcSld.SlideID & ".png", "PNG"


                        .Background.Fill.UserPicture SrcPPT.path & SrcSld.SlideID & ".png"
                        Kill (SrcPPT.path & SrcSld.SlideID & ".png")


                        SrcSld.DisplayMasterShapes = bMasterShapes
                        If SrcSld.Shapes.Count > 0 Then SrcSld.Shapes.Range.Visible = True


                    Case Is = msoFillPatterned
                        .Background.Fill.Patterned (SrcSld.Background.Fill.Pattern)


                    Case Is = msoFillGradient


                        ' inspect gradient type
                        Select Case SrcSld.Background.Fill.GradientColorType
                        Case Is = msoGradientTwoColors
                            .Background.Fill.TwoColorGradient _
                                SrcSld.Background.Fill.GradientStyle, _
                                SrcSld.Background.Fill.GradientVariant
                        Case Is = msoGradientPresetColors
                            .Background.Fill.PresetGradient _
                                SrcSld.Background.Fill.GradientStyle, _
                                SrcSld.Background.Fill.GradientVariant, _
                                SrcSld.Background.Fill.PresetGradientType
                        Case Is = msoGradientOneColor
                            .Background.Fill.OneColorGradient _
                                SrcSld.Background.Fill.GradientStyle, _
                                SrcSld.Background.Fill.GradientVariant, _
                                SrcSld.Background.Fill.GradientDegree
                        End Select


                    Case Is = msoFillBackground
                        ' Only shapes - we shouldn't come here
                End Select
            End If


            ' >>>>>>>>>>>>>>>>>>>>


        End With
    Next Idx


End Sub

 

[blokeyhighlander]

Hate to bump the thread, but any ideas on this?

I find it strange that the code successfully runs in both PowerPoint and Excel, but that the slide formatting changes when called from Excel, and not from PowerPoint.