Positioning of PlotArea within ChartArea in Powerpoint with VBA - excel

(Post updated with entire code, sorry about the beginner mistake)
Newbie to both coding and VBA here and I'm trying to adjust the PlotArea for a Chart in a presentation. I'm running this from Excel.
Creating and populating the Chart goes fine, sizing ChartArea is also no problems and formating all titles etc is also without problems.
When the Chart looks athe way I want it to, is the correct size and at the correct place, I want the PlotArea to be a precise size and in a precise location. Sizing goes well but the position does not work.
Here is the code that I use, Including populating the ChartData with dummy data and adding in a red box to show where I want the PlotArea to sit:
Sub CreateChart()
'Declare Excel Object Variables
Dim pptWorkBook As Excel.Workbook
Dim pptWorkSheet As Excel.Worksheet
'Declare PowerPoint Object Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTChart As PowerPoint.Chart
Dim PPTChartData As PowerPoint.ChartData
Dim SldHeight, SldWidth As Integer
Dim ChrHeight, ChrWidth As Single
Dim PlotHeight, PlotWidth As Double
'Declare Excel Object Variable
Dim ExcRange As Range
'Create a new instance of Powerpoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation within the Application
Set PPTPres = PPTApp.Presentations.Add
'Disable Snap-To-Grid
PPTPres.SnapToGrid = msoFalse
'Create a new slide within the Presentation
Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)
'Find out size (points) of Slide
SldHeight = PPTPres.PageSetup.SlideHeight
SldWidth = PPTPres.PageSetup.SlideWidth
'Calculate Chart and Plot Size
ChrWidth = 954
ChrHeight = 525 - 106
PlotWidth = 866 - 95
PlotHeight = 437 - 106 - 20
'No screen updates
Application.ScreenUpdating = False
'Create a new Chart within the Slide, give it proper size
Set PPTShape = PPTSlide.Shapes.AddChart2(-1, xlColumnClustered, 0, 106, ChrWidth, ChrHeight, True)
'Minimize ChartData
PPTShape.Chart.ChartData.Workbook.Application.WindowState = -4140
'Set chartdata
Set PPTChartData = PPTShape.Chart.ChartData
'Set Workbook object reference
Set pptWorkBook = PPTChartData.Workbook
'Set Worksheet object reference
Set pptWorkSheet = pptWorkBook.Worksheets(1)
'Add Data
pptWorkSheet.ListObjects("Table1").Resize pptWorkSheet.Range("A1:B5")
pptWorkSheet.Range("b1").Value = "Items"
pptWorkSheet.Range("a2").Value = "Bikes"
pptWorkSheet.Range("a3").Value = "Accessories"
pptWorkSheet.Range("a4").Value = "Repairs"
pptWorkSheet.Range("a5").Value = "Clothing"
pptWorkSheet.Range("b2").Value = "1000"
pptWorkSheet.Range("b3").Value = "2500"
pptWorkSheet.Range("b4").Value = "4000"
pptWorkSheet.Range("b5").Value = "3000"
'Apply Style
With PPTShape.Chart
.ChartStyle = 4
End With
'Remove title
With PPTShape.Chart
.HasTitle = False
End With
'Format legend
With PPTShape.Chart
.HasLegend = True
.Legend.Position = xlLegendPositionTop
.Legend.Top = 0
End With
'Add axis title
With PPTShape.Chart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Dollars"
End With
'Remove gridlines
With PPTShape.Chart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
'Add data labels
PPTShape.Chart.ApplyDataLabels
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideLeft = 95
.InsideTop = 20
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
End With
'Adding a red textbox with the same dimensions and position as the PlotArea
With PPTShape.Chart.Shapes.AddTextbox(msoTextOrientationDownward, 95, 20, PlotWidth, PlotHeight)
.Line.Weight = 2
.Line.DashStyle = msoLineLongDash
.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
'Quit
Set pptWorkSheet = Nothing
pptWorkBook.Application.Quit
Set pptWorkBook = Nothing
Set PPTChartData = Nothing
Set PPTChart = Nothing
'Screen updates
Application.ScreenUpdating = True
End Sub
Below you can see the result with dummy data. The red box is correct, the PlotArea is the right size but not in the right position. Am I misunderstanding something regarding the InsideLeft vs Left properties? I've been stuck here for hours now and I am not making any progress. A theory a colleague and I have is that the PlotArea is doing a Snap-To to something that can't be seen.
Any help is appreciated!
UPDATE:
I changed the order of positioning and sizing of the PlotArea and it improved.
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95
.InsideTop = 20
End With
The offset from the red box seems consistent and I'm sure it is a small thing I am missing somewhere. See attached image of the new result below.
UPDATE 2:
Here is how I solved this. I'm not entirely sure it is correct logic, but it works at least.
I need to offset the PlotArea by 3.9 points. This seems to involve spacing for TickMarks. My assumption here is that the PlotArea position (.InsideTop and .InsideLeft etc) include TickMark width and height but lacks the means to adjust for this. My workaround looks like this:
'Set the TickMark offset constant
offSet = 3.9
'Set PlotArea position and size
With theShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95 - offSet
.InsideTop = 20 - offSet
End With
As this is mostly guesswork, as far as a solution is concerned, any real answers and not workarounds would still be appreciated.

It seems you're trying to position the chart, not the plot area. Try something like this instead:
'Set PlotArea size and position
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.Left = 60
.Top = -25
End With

Related

How do I adjust this code to change title text on each powerpoint slide

I am trying to create an excel vba macro that loops through each slide in a presentation (the presentation was created with an excel vba macro) and adds specific text to the top of each slide.
Right now, this is what I have but it is throwing an error and I can figure out the set slide_title section and the with section. I think the for loop is correct, but not understanding the "with" section. The "with" section text box characteristics are correct....but the code isn't executing because something is clearly wrong with it.
Sub update_slide_title_text()
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoCTrue
ppt.Presentations.Open ("C:\Users\Existing_Presentation.pptx")
Dim ppres As PowerPoint.Presentation
Set ppres = ppt.ActivePresentation
Dim pslide As PowerPoint.Slide
Dim pshape As PowerPoint.Shape
For Each pslide In ppres.Slides
Dim slide_title As Object
Set slide_title = pslide.Shapes.AddTextbox(1, 34.36292, -2.670787, 900, 90)
With slide_title
.Height = 54
.Left = 34.36292
.Top = 15
.Width = 190
.TextFrame.TextRange.Text = "NEED TO CHANGE THIS TO DIFFERENT TEXT FOR EACH SLIDE"
.TextFrame.TextRange.Font.Bold = True
.TextFrame.TextRange.Font.Size = 20
.TextFrame.TextRange.Font.Color = RGB(0, 133, 85)
End With
Next
End Sub

Edit legend using VBA

I copied chart (this chart with legend I prepared in excel) from excel to .ppt (below code). How can I change/edit legend.Top and legend.size?
My code is not working...
Sub pptfromexcel()
Dim pptapp As PowerPoint.Application
Dim pptppt As PowerPoint.Presentation
Dim pptsld As PowerPoint.Slide
Dim shp As Object
Set chart1 = ActiveSheet.ChartObjects("Chart 1")
'Dane do wykresów
Set d5 = Sheets("Wykresy").Range("Q32:S40")
Set d6 = Sheets("Wykresy").Range("Q47:S51")
Set v1PK = Sheets("Wykresy").Range("G7:G7")
Set v1PM = Sheets("Wykresy").Range("G8:G8")
Set pptapp = New PowerPoint.Application
Set pptppt = pptapp.Presentations.Open("C:\Users\Desktop\ppt.pptx")
pptapp.Visible = True
pptapp.Activate
Set pptsld2 = pptppt.Slides(2)
chart1.Copy
Set chart1a = pptsld2.Shapes.PasteSpecial
With chart1a
.Height = 132
.Width = 157
.Left = 26.1
.Top = 120
.haslegend=true
.legend.size = 12
.legend.top = 150
End With
End Sub
The first four properties your are setting are generic properties for all shapes. The legend properties are specific for a chart. The first thing that must happen is that it is pasted as an Excel object. If that is the case, you have a Chart property on your shape and you can do like this:
With chart1a
.Height = 132
.Width = 157
.Left = 26.1
.Top = 120
.Chart.HasLegend = True
.Chart.Legend.Size = 12
.Chart.Legend.Top = 150
End With

How to copy chart from excel to word and embed chart data in word file

I have excel with data that I'm writing in word, it is open and I try to copy chart from excel to word, without linking it, so that any other user can open it without static link to original excel file.
Sub Make4Segment(Wapp As Object)
Dim Sheet As Excel.Worksheet
Dim MyChart As ChartObject
Set Sheet = Excel.ThisWorkbook.Sheets("DOC")
Set MyChart = Excel.ThisWorkbook.Sheets("DOC").ChartObjects("C1")
MyChart.Chart.ChartArea.Copy
With Wapp.Application.Selection.Range
.PasteAndFormat Type:=wdChart
End With
End sub
I'm getting error 4605 on paste line.
Change:
.PasteAndFormat Type:=wdChart
With:
.PasteSpecial Link:=False, DataType:=26
That should paste the Object correctly with Data and Without Link
You can Try with these different datatypes if this one is not what you need.
To reader in future: I was unable to find easy copy/paste solution to copy chart form excel to word. So I created this monstrosity. It creates chart in word, copies data for chart form excel file and embeds data in word file. Loads chart settings from excel files cells for ease of changing chart appearance. Resulting word document is independent and with chart data, and can be sent to anyone.
Sub GenerateReport()
Dim Wapp As Object
'Launches word application
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Activate
...
Call CreateChart(Wapp)
End Sub
'Procedure, that creates chart in Word
Sub CreateChart(Wapp As Object)
Dim Ch4y As Word.InlineShape
Dim EmChData As Excel.Worksheet
Dim SrDataSh As Excel.Worksheet
Dim FomtCh As Excel.ChartObject
Dim DbWidth As Double
Dim DbHeight As Double
Dim DbIndentCh As Double
Dim DbLineWeight As Double
Dim DbDegrees As Double
Dim DbChLeHeight As Double
Dim DbChLeWidth As Double
Dim DbChLeLeft As Double
Dim DbChLeTop As Double
Dim LnChType As Long
Dim LnXLabelSpace As Long
Dim LnYMayorUnit As Long
Dim LnYMinimumScale As Long
Dim LnChBorder As Long
Dim LnChFontSize As Long
Dim BoLegend As Boolean
Dim BoTitle As Boolean
Dim In1 As Integer
Dim In2 As Integer
Dim In3 As Integer
Dim In4 As Integer
Dim In5 As Integer
Dim In6 As Integer
Dim In7 As Integer
Dim In8 As Integer
Dim In9 As Integer
Dim StChFont As String
'Creates new chart in word
Set Ch4y = Wapp.ActiveDocument.InlineShapes.AddChart2
'Embed data in chart, to make it independent form excel
'Creates reference to place where data will be stored
Set EmChData = Ch4y.Chart.ChartData.Workbook.Worksheets(1)
'Creates reference to source data sheet
Set SrDataSh = Excel.ThisWorkbook.Sheets("DOC")
'Loads data from Excel sheet for customizability
DbWidth = SrDataSh.Range("A159").Value '490
DbHeight = SrDataSh.Range("A160").Value '180
DbIndentCh = SrDataSh.Range("A161").Value '0
LnChType = SrDataSh.Range("A162").Value '4
BoLegend = SrDataSh.Range("A163").Value 'True
BoTitle = SrDataSh.Range("A164").Value 'False
In1 = SrDataSh.Range("A166").Value '139
In2 = SrDataSh.Range("A167").Value '231
In3 = SrDataSh.Range("A168").Value '246
In4 = SrDataSh.Range("A170").Value '0
In5 = SrDataSh.Range("A171").Value '133
In6 = SrDataSh.Range("A172").Value '155
DbLineWeight = SrDataSh.Range("A173").Value '1.75
DbDegrees = SrDataSh.Range("A174").Value '90
LnXLabelSpace = SrDataSh.Range("A175").Value '1
LnYMayorUnit = SrDataSh.Range("A176").Value '10
LnYMinimumScale = SrDataSh.Range("A177").Value '70
LnChBorder = SrDataSh.Range("A178").Value '-4142
StChFont = SrDataSh.Range("A179").Value 'Open Sans
LnChFontSize = SrDataSh.Range("A180").Value '9
In7 = SrDataSh.Range("A182").Value '151
In8 = SrDataSh.Range("A183").Value '151
In9 = SrDataSh.Range("A184").Value '151
DbChLeHeight = SrDataSh.Range("A185").Value '18
DbChLeWidth = SrDataSh.Range("A186").Value '200
DbChLeLeft = SrDataSh.Range("A187").Value '140
DbChLeTop = SrDataSh.Range("A188").Value '155
'Clears range
EmChData.Range("A1:XFD1048576").Clear
'Copy data
EmChData.Range("A1:C49").Value = SrDataSh.Range("B109:D157").Value
'Set Source data
Ch4y.Chart.SetSourceData Source:="'Sheet1'!$A$1:$C$49", PlotBy:=xlColumns
'Create reference to excel chart
Set FomtCh = ThisWorkbook.Sheets("Doc").ChartObjects(1)
With Wapp
With .Selection
'This line change position of chart that will be created to left or to right
.ParagraphFormat.LeftIndent = DbIndentCh
End With
End With
'Creates needed formating
With Ch4y
'Set size for chart
.Width = DbWidth
.Height = DbHeight
With .Chart
'Sets chart type
.ChartType = LnChType
'Sets chart legend to visible/unvisable
.HasLegend = BoLegend
'Sets chart title visible/unvisable
.HasTitle = BoTitle
'Sets color back to original for data series lines (for some reason it is not pasted in previous line)
.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(In1, In2, In3)
.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(In4, In5, In6)
'Sets line thicknes
.SeriesCollection(1).Format.Line.Weight = DbLineWeight
.SeriesCollection(2).Format.Line.Weight = DbLineWeight
'Works with x-axis
With .Axes(xlCategory)
'Sets orientation of x axis labels
.TickLabels.Orientation = DbDegrees
'Force to show all month under x-axis
.TickLabelSpacing = LnXLabelSpace
End With
'Works with y-axis
With .Axes(xlValue)
'Sets unit size for y-axis
.MajorUnit = LnYMayorUnit
'Sets value on y-axis from where values will start (Changes y=0 to value specified)
.MinimumScale = LnYMinimumScale
End With
With .ChartArea
'Sets border to none
.Border.LineStyle = LnChBorder
'Sets font
.Format.TextFrame2.TextRange.Font.Name = StChFont
'Sets font size
.Format.TextFrame2.TextRange.Font.Size = LnChFontSize
'Sets chart font color
.Font.Color = RGB(In7, In8, In9)
End With
'Checks if Legend for chart is enabled
If .HasLegend = True Then
With .Legend
'Sets height of legend
.Height = DbChLeHeight
'Sets width of legend
.Width = DbChLeWidth
'Sets distance from left side of chart
.Left = DbChLeLeft
'Sets distance from top side of chart
.Top = DbChLeTop
End With
End If
End With
End With
End Sub

Deleting specific ChartObjects by Name Property Excel VBA

I have an excel worksheet with two chart objects (pie chart and line graph). I have separate buttons to generate each graph and I want to delete the according pre-existing graph each time the generation button is pressed. Right now, I am attempting to access the Name property of the chart object to determine if the chart needs to be deleted. The deletion code looks like this:
For i = 1 To ActiveSheet.ChartObjects.Count
If ActiveSheet.ChartObjects(i).Chart.Name = "Genre" Then
ActiveSheet.ChartObjects("Genre").Delete
End If
Next i
Here is the code that generates the piechart:
Range("A2:B16").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlPie 'Exploded
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.ChartTitle.Text = "Genre Breakdown"
ActiveChart.Parent.Name = "Genre"
Dim ChartSize As ChartObject
Set ChartSizing = Worksheets("Graphs and Stats").ChartObjects("Genre")
With ChartSizing
.Top = Range("D2").Top
.Width = Range("D2:H23").Width
.Height = Range("D2:H23").Height
.Left = Range("D2").Left
End With
Currently, the If-statement in the deletion for loop never resolves as true and I don't understand why. What is wrong with that line and/or is there better logic I could be using to check for pre-existing charts? I would prefer not use
ActiveSheet.ChartObjects.Delete
if I can avoid it to keep the generation buttons separate from each other.
EDIT: Corrected code (where worksheet name is "Graphs and Stats") using Dammer15's solution:
For i = 1 To ActiveSheet.ChartObjects.Count
If ActiveSheet.ChartObjects(i).Chart.Name = "Graphs and Stats Genre" Then
ActiveSheet.ChartObjects("Genre").Delete
End If
Next i
Set Rng = ActiveSheet.Range("A2:B16")
Set GenreChart = ActiveSheet.Shapes.AddChart
GenreChart.Name = "Genre"
With GenreChart.Chart
.SetSourceData Source:=Rng
.ChartType = xlPie
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = "Genre Breakdown"
End With
You never get the correct Chart Name. Use the sheets and indexing you need but here's the general idea. You must remove the Sheet name from the accessed property.
'List of Chart Objects
Dim ChartList As ChartObjects
'The square that holds the chart
Dim MyChartFrame As ChartObject
Dim ChartToDelete As ChartObject
'The Physical chart with data
Dim MyChart As Chart
'Accessing the Objects
Set ChartList = Sheet1.ChartObjects
Set MyChartFrame = Sheet1.ChartObjects(1)
Set MyChart = MyChartFrame.Chart
Dim ChartName As String
'Remove SheetName from ChartName!!!!
ChartName = MyChart.Name
'Deleting Chart
Set ChartToDelete = Sheet1.ChartObjects(ChartName)
ChartToDelete.Delete

Issue plotting excel tables to multiple powerpoint slides

I have created a template on excel which is populated with data for a specific country. The template contains 3 tables and a chart (line graph). I have a list of countries that I need to loop through, and for each loop, I need to create a powerpoint slide made up of the 3 tables and chart.
I build the macro below using bits from various sources (mostly from this platform). The macros scales and positions each of the elements. The first slide populates correctly, but I am running into the following issues:
All the tables and charts are positioned correctly on the first slide, but are not being positioned on every other slide. Note that the objects are still being scaled correctly
I get Run-time error ‘-214788160 (80048240): Selection (unknown member) : Invalid request. This view does not support selection
Does anyone have any suggestions for what the issue could be?
Sub MulipleCountrySlides()
'Step 1: Declare your variables
Dim ListOfSystems As Variant
Dim pptLayout As CustomLayout
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlides As PowerPoint.Slides
Dim PPSlide As PowerPoint.Slide
Dim SlideTitle As String
Dim XLS_Out As Variant
Dim shp As Object
Dim chtObj As ChartObject
Dim chtTop As Double
Dim chtLeft As Double
Dim chtWidth As Double
Dim chtHeight As Double
'Step 2: Open PowerPoint and create new presentation
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'Step 3: Add new slide as slide 1 and set focus to it
PPPres.ApplyTemplate "C:\Users\yogeswaran saravanan\AppData\Roaming\Microsoft\Templates\blank.potx"
ListOfSystems = Range("listofsystemstest") 'This is the list of systems that I will be looping through
For y = LBound(ListOfSystems) To UBound(ListOfSystems)
Set PPSlide = PPPres.Slides.Add(y, ppLayoutTitleOnly)
Worksheets("System output sheet").Range("j2").Value = ListOfSystems(y, 1)
Sheets("Indexed data").Calculate
ActiveSheet.Calculate
If Not Application.CalculationState = xlDone Then ' Calculation takes a while to run
DoEvents
End If
Set PPSlide = PPPres.Slides(y)
'The following arrays specify the regions/charts to be copied/pasted,
'the sizes/positions of these regions/charts, and the slide numbers corresponding
'to region/chart destinations
'Region/chart widths (Length/width ratios are preserved)
OWidth = Array(910, 450, 900, 465) '' 72px per Inch
OHeight = Array(400, 120, 33, 147)
'Horizontal positions on slides
OLeft = Array(22, 22, 22, 22)
'Vertical positions on slides
OTop = Array(100, 360, 504, 200)
'Regions and charts to be copied/pasted
XLS_Out = Array(Range("Countryslidetable"), _
Range("Chartdeltas"), _
Range("Countryfootnote"), _
Worksheets("System output sheet").ChartObjects("Chart 1"))
'Region/Chart type: 1 corresponds to chart objects, 0 corresponds to regions
XLS_OutFormat = Array(0, 0, 0, 1)
'Loop through arrays and copy/paste regions and charts one at a time
For x = 0 To 3 'LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel range/chart
XLS_Out(x).Copy
'Paste to PowerPoint
If (XLS_OutFormat(x) = 0) Then
'Paste an Excel range
Set shp = PPPres.Slides(y).Shapes.PasteSpecial(ppPasteHTML)
Else
'Paste an Excel chart
Set shp = PPPres.Slides(y).Shapes.PasteSpecial(ppPasteShape)
shp.LinkFormat.BreakLink
End If
'Change position/size of pasted regions/charts based on previously-defined arrays
With PPPres.Slides(y)
'shp.LockAspectRatio = msoTrue
shp.Height = OHeight(x)
shp.Width = OWidth(x)
shp.Top = OTop(x)
shp.Left = OLeft(x)
shp.ZOrder msoSendToFront
'End With
If (XLS_OutFormat(x) = 0) Then
If (x = 2) Then
PP.ActiveWindow.Selection.ShapeRange.TextEffect.FontSize = 10
End If
If (x = 0) Then
'Set oShp = PPSlide.Shapes(1)
'Set oShp = PP.ActiveWindow.Selection.ShapeRange
Set oTbl = shp.Table
For i = 1 To oTbl.Columns.Count
For J = 1 To oTbl.Rows.Count
'oShp.TextFrame.TextRange.Font.Size = 11
oTbl.Cell(J, i).Shape.TextFrame.TextRange.Font.Size = 11
Next
Next
End If
End If
End With
Next x
'Step 6: Add the title to the slide
SlideTitle = "Country Price Recommendations: " & Worksheets("System output sheet").Range("J2")
PPPres.Slides(y).Shapes.Title.TextFrame.TextRange.Text = SlideTitle
'Step 7: Memory Cleanup
PP.Activate
Next y
Set PPSlide = Nothing
Set PPPres = Nothing
Set PP = Nothing
End Sub

Resources