Resizen graph in PowerPoint

[Djani]

Hoi allemaal,

Ik heb al een stuk kunnen vinden op de site van PeltierTech, maar het lukt mij niet om de geselecteerde grafiek te centraliseren met de gewenste afmetingen.

Sub ChartToPresentation()
         
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim shp As String
       
' Make sure a chart is selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again.", vbExclamation, _
        "No Chart Selected"
Else
    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    ' Reference active slide
    Set PPSlide = PPPres.Slides(4)
        
                
    ' Copy chart as a picture
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
        Format:=xlPicture

    ' Paste chart
    PPSlide.Shapes.Paste.Select

With PPSlide
    .Shapes(shp).IncrementLeft 1.12
    .Shapes(shp).IncrementTop 3.55
    .Shapes(shp).ScaleWidth 0.65, msoFalse, msoScaleFromTopLeft
    .Shapes(shp).ScaleHeight 0.65, msoFalse, msoScaleFromTopLeft
End With

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

End Sub

Kunnen jullie mij helpen? Het maakt niet uit welke getallen ik verander, de grafiek blijft altijd even groot. Mis ik iets?

Mvg,

Djani

 

[etri]

Djani,

Volgens mij stel je nergens de variabele shp in. Dus die is leeg ("") denk ik?

Overigens zou ik zelf een object maken van het type Shape en die 'setten' op de nieuwe geplakte shape:

Dim newShape as PowerPoint.Shape
Set  newShape = PPSlide.Shapes.Paste

Vervolgens kun je dan hiernaar verwijzen:

With newShape
    .IncrementLeft 1.12
    .IncrementTop 3.55
    .ScaleWidth 0.65, msoFalse, msoScaleFromTopLeft
    .ScaleHeight 0.65, msoFalse, msoScaleFromTopLeft
End With

Ik doe dit overigens allemaal uit mijn hoofd en dus is bovenstaande niet getest. Maar ik denk dat mijn bedoeling wel overkomt, toch?

Succes!

 

[Djani]

Thanks voor je hulp. Ik heb wat aangepast in de code --> hij plakt wel de grafiek (niet aangepast aan de nieuwe afmetingen), maar geeft daarna een error "Type mismatch" bij:

"Set newShape = PPSlide.Shapes.Paste.

Ik heb gekeken of er iets niet consistent was, maar misschien zie ik iets over het hoofd. Het resizen werkt ook nog steeds niet. Ik zal voor de zekerheid het voorbeeldbestand in de bijlage zetten. De macro heb ik erin zitten.

Bekijk bijlage Example report.xlsx

Mvg,

Djani

 

[etri]

Ah, mijn fout. Het moet zijn:

Dim newShape as PowerPoint.ShapeRange

Ik heb het net getest erbij mij werkt het aanpassen van de locatie en grootte nu wel.

Tip: als je een type mismatch error krijgt dan is het type variabele niet goed (in dit geval was het Shape en moest het ShapeRange zijn). Door op de methode te klikken (in dit geval .Paste in de regel "... = PPSlide.Shapes.Paste") en op F2 klikt dan wordt er in het nieuwe venster onderaan getoond welk type variabele .Paste retourneert. Wel zo handig!

Succes nogmaals!

 

[Djani]

Thanks man. Voor degenen die geinteresseerd zijn in de script, bij deze:

Sub ChartToPresentation()
         
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim shp As String
Dim newShape As PowerPoint.ShapeRange


' Make sure a chart is selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again.", vbExclamation, _
        "No Chart Selected"
Else
    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    ' Reference active slide
    Set PPSlide = PPPres.Slides(4)
               
    ' Copy chart as a picture
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
        Format:=xlPicture

    ' Paste chart
    Set newShape = PPSlide.Shapes.Paste

With newShape
    .IncrementLeft 400
    .IncrementTop 250
    .ScaleWidth 0.87, msoFalse, msoScaleFromTopLeft
    .ScaleHeight 0.87, msoFalse, msoScaleFromTopLeft
End With

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

End Sub

Mvg,

Djani