I have a powerpoint presentation with 100 slides and most of them have linked excel charts. I am trying to run a macro that will cycle through the slides and then the shapes on the slides and find the linked chart/graph, copy it, and paste it into the same position as a metafile so that I can make an emailable pdf file. However, the macro is skipping over the chart or not recognizing it as a chart. I searched and searched, any help would be much appreciated.
Sub Select_All()
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
Dim oSlide As Slide
Dim oSlides As SlideRange
Dim oShape As Shape
Dim slideNumber As Integer
Dim shapeNumber As Integer
Dim lastslideNumber As Integer
Dim lastshapeNumber As Integer, i As Integer
Dim w As Double
Dim h As Double
Dim l As Double
Dim t As Double
For slideNumber = 14 To 100
oPresentation.Slides(slideNumber).Select
For i = 1 To oPresentation.Slides(slideNumber).Shapes.Count
If oPresentation.Slides(slideNumber).Shapes(i).HasChart Then
oPresentation.Slides(slideNumber).Shapes(i).Select
oPresentation.Slides(slideNumber).Shapes(i).Copy
With ActiveWindow.Selection.ShapeRange(1)
w = .Width
h = .Height
l = .Left
t = .Top
End With
oPresentation.Slides(slideNumber).Shapes(i).Delete
oPresentation.Slides(slideNumber).Shapes.PasteSpecial (ppPasteEnhancedMetafile)
With ActiveWindow.Selection.ShapeRange
'.Width = w
'.Height = h
.Left = l
.Top = t
.ZOrder msoSendToBack
End With
End If
Next i
Next slideNumber
End Sub
This should be cleaner but you can save the copy/paste step if you simply ungroup the chart shape. That'll give you a metafile directly.
Sub Select_All()
Dim oPresentation As Presentation
Set oPresentation = ActivePresentation
Dim oSlide As Slide
Dim oSlides As SlideRange
Dim oShape As Shape
' These should be Longs
Dim slideNumber As Long
Dim shapeNumber As Long
Dim lastslideNumber As Long
Dim lastshapeNumber As Long
Dim i As Long
Dim w As Double
Dim h As Double
Dim l As Double
Dim t As Double
For slideNumber = 14 To 100
'oPresentation.Slides(slideNumber).Select
' never select anything unless you absolutely must
Set oSlide = oPresentation.Slides(slidenumber)
For i = oSlide.Shapes.Count to 1 step -1
' Step through shapes backward, else you'll run into weird
' side effects when deleting shapes
If oSlide.Shapes(i).HasChart Then
'oPresentation.Slides(slideNumber).Shapes(i).Select
' don't select anything etc etc
oSlide.Shapes(i).Copy
With oSlide.Shapes(i)
w = .Width
h = .Height
l = .Left
t = .Top
End With
oSlide.Shapes(i).Delete
set oShape = oSlide.Shapes.PasteSpecial (ppPasteEnhancedMetafile)(1)
With oShape
'.Width = w
'.Height = h
.Left = l
.Top = t
.ZOrder msoSendToBack
End With
End If
Next i
Next slideNumber
Related
I need a macro for deleting all datalabels in a linechart except the last two.
I've managed to delete one column of labels, any help on how i can delete the rest.
Here is the code im using currently:
Option Explicit
Sub Format_linechart()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
Dim Cnt As Integer
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.HasChart Then
Set chart = shp.chart
For i = 1 To chart.SeriesCollection.Count
Set sr = chart.SeriesCollection(i)
sr.HasDataLabels = True
sr.Points(sr.DataLabels.Count - 2).DataLabel.Delete
Next i
End If
Next shp
End Sub
I've also tried adding lines for each set of datalabels but i then get an error if there are to few datapoints in the chart.
Option Explicit
Sub Format_linechart()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
Dim Cnt As Integer
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.HasChart Then
Set chart = shp.chart
For i = 1 To chart.SeriesCollection.Count
Set sr = chart.SeriesCollection(i)
sr.HasDataLabels = True
sr.Points(sr.DataLabels.Count - 2).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 3).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 4).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 5).DataLabel.Delete
sr.Points(sr.DataLabels.Count - 6).DataLabel.Delete
Next i
End If
Next shp
End Sub
For each each series, you can loop through each point and delete the data label for the desired points . . .
Option Explicit
Sub Format_linechart()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
Dim j As Long
Dim Cnt As Integer
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.HasChart Then
Set chart = shp.chart
For i = 1 To chart.SeriesCollection.Count
Set sr = chart.SeriesCollection(i)
sr.HasDataLabels = True
For j = 1 To sr.Points.Count - 2
sr.Points(j).DataLabel.Delete
Next j
Next i
End If
Next shp
End Sub
I am trying to create a macro which copies the text from all the tables in a slide. I can select the tables but failed to copy text entries from tables. I need to paste the copied text to a excel spreadsheet.
Here is the script:
Option Explicit
Sub GetTableNames()
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Dim pptSlide As Slide
Set pptSlide = Application.ActiveWindow.View.Slide
Dim pptShapes As Shape
Dim pptTable As Table
For Each pptSlide In pptpres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.HasTable Then
Set pptTable = pptShapes.Table
pptShapes.Select msoFalse
pptShapes.TextFrame.TextRange.Copy
End If
Next
Next
End Sub
enter image description here
enter image description here
Try this code:
Sub GetTableNames()
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Dim pptSlide As Slide
Set pptSlide = Application.ActiveWindow.View.Slide
Dim pptShapes As Shape, pptTable As Table
Dim XL As Object, WS As Object
Dim arr As Variant, nextTablePlace As Integer, cnt As Integer
Set XL = CreateObject("Excel.Application")
With XL.Workbooks.Add
Set WS = .Worksheets(1)
End With
nextTablePlace = 1 ' to output first table content into Worksheet
For Each pptSlide In pptpres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.HasTable Then
cnt = cnt + 1
Set pptTable = pptShapes.Table
WS.Cells(nextTablePlace, 1) = "Table #: " & cnt ' caption for each table
nextTablePlace = nextTablePlace + 1
ReDim arr(1 To pptTable.Rows.Count, 1 To pptTable.Columns.Count) ' resize array to table dimensions
For rr = 1 To pptTable.Rows.Count
For cc = 1 To pptTable.Columns.Count
arr(rr, cc) = pptTable.Cell(rr, cc).Shape.TextFrame.TextRange.Text 'get text from each cell into array
Next
Next
' flush the arr to Worksheet
WS.Cells(nextTablePlace, 1).Resize(pptTable.Rows.Count, pptTable.Columns.Count) = arr
' to next place with gap
nextTablePlace = nextTablePlace + pptTable.Rows.Count + 2
End If
Next
Next
XL.Visible = True
End Sub
Sub Export_Allcahrts_ppt()
Dim mypowerpoint As PowerPoint.Application
Set mypowerpoint = New PowerPoint.Application
mypowerpoint.Visible = msoTrue
Dim mypowerpoint_pres As PowerPoint.Presentation
Set mypowerpoint_pres = mypowerpoint.Presentations.Add
Dim myslide As PowerPoint.Slide
Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank)
Dim mychart As ChartObject
Dim j As Long
j = 0
For Each mychart In Sheet1.ChartObjects
j = j + 1
Next
For Each mychart In Sheet1.ChartObjects
mychart.Copy
myslide.Shapes.PasteSpecial ppPasteBitmap
myslide.Shapes(1).Top = 100
myslide.Shapes(1).Height = 200
myslide.Shapes(1).Left = 30
If mypowerpoint_pres.Slides.Count < j Then
Set myslide = mypowerpoint_pres.Slides.Add(mypowerpoint_pres.Slides.Count + 1, ppLayoutBlank)
Else
Exit Sub
End If
Next
End Sub
First, you don't need to loop to get j; just use
j = Sheet1.ChartObjects.Count
But you also don't need j at all. What your code does is insert a new slide for each new chart if the number of slides does not yet equal the number of charts copied so far.
So try this slightly rearranged and streamlined code. I haven't tested it, but I don't think I've changed the syntax.
Sub Export_Allcahrts_ppt()
Dim mypowerpoint As PowerPoint.Application
Dim mypowerpoint_pres As PowerPoint.Presentation
Dim myslide As PowerPoint.Slide
Dim mychart As ChartObject
Dim j As Long
Set mypowerpoint = New PowerPoint.Application
mypowerpoint.Visible = msoTrue
Set mypowerpoint_pres = mypowerpoint.Presentations.Add
Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank)
j = Sheet1.ChartObjects.Count
For Each mychart In Sheet1.ChartObjects
mychart.Copy
myslide.Shapes.PasteSpecial ppPasteBitmap
With myslide.Shapes(myslide.Shapes.Count)
.Top = 100
.Height = 200
.Left = 30
End With
Next
End Sub
I want to combine shapes based on range selection. Like this picture. Is it possible?
Here I attached the images:
Here I attached my code
Sub cohabitationButton_Click()
'''''split range
Dim s() As String
Dim txt As String
Dim i As Long
s = Split(Selection.Address(False, False), ",")
For i = LBound(s) To UBound(s)
Dim r As range: Set r = range(s(i))
With r
l = .Left - 5
t = .Top - 5
w = .Width + 10
h = .Height + 10
End With
ShapeName = "ex"
With ActiveSheet.Shapes.AddShape(msoShapeFlowchartTerminator, l, t, w, h)
.Fill.Visible = msoFalse
.Line.Weight = 1
.Line.DashStyle = msoLineDash
.Line.ForeColor.RGB = BASICCOLOR
.Name = ShapeName
End With
Next i
End Sub
There is no possibility to combine shapes in Excel. But here is an example how you can draw combined borders around your selections. This might be an option for you.
So with the selection of your example we end up with this:
Sub DrawCombinedBordersOnly()
'''''split range
Dim s() As String
Dim txt As String
Dim i As Long
Dim rngOverlappings As Range
'Draw borders around all selected ranges
Selection.BorderAround LineStyle:=xlDot, Weight:=xlThin
s = Split(Selection.Address(False, False), ",")
For i = LBound(s) To UBound(s)
Dim r As Range: Set r = Range(s(i))
Dim j As Long
For j = LBound(s) To UBound(s)
'find overlapping areas
If i <> j And Not Application.Intersect(r, Range(s(j))) Is Nothing Then
If rngOverlappings Is Nothing Then
Set rngOverlappings = Application.Intersect(r, Range(s(j)))
Else
Set rngOverlappings = Union(rngOverlappings, Application.Intersect(r, Range(s(j))))
End If
End If
Next j
Next i
' remove borders from overlappings
If Not rngOverlappings Is Nothing Then
rngOverlappings.Borders.LineStyle = xlNone
End If
End Sub
Try This and remove apostrophe ' before ' Range("D5:F9,F8:H12,H11:J15").Select 'for test
Sub cohabitationButton_Click()
'''''split range
Dim WB As Workbook
Dim WS As Worksheet
Dim s() As String
Dim txt As String
Dim i As Long
Dim Shp As Shape
Dim L As Single, T As Single, Lft As Single, Tp As Single
Set WB = ThisWorkbook 'Set WB = Workbooks("WorkbookName")
Set WS = WB.ActiveSheet 'Set WS = WB.WorkSheets("WorkSheetName")
With WS
For Each Shp In .Shapes
If Shp.Type = 5 Then Shp.Delete
Next
' Range("D5:F9,F8:H12,H11:J15").Select 'for test***
MyRange = Selection.Address
s = Split(Selection.Address(False, False), ",")
Dim Names(1 To 100) As Variant
For i = LBound(s) To UBound(s)
Dim r As Range: Set r = Range(s(i))
With r
L = .Left - 5
T = .Top - 5
w = .Width + 10
h = .Height + 10
If i = LBound(s) Then
Lft = L
Tp = T
End If
If Lft > L Then Lft = L
If Tp > T Then Tp = T
End With
ShapeName = "ex"
With .Shapes.AddShape(msoShapeFlowchartTerminator, L, T, w, h)
.Fill.Visible = msoFalse
.Line.Weight = 1
.Line.DashStyle = msoLineDash
.Line.ForeColor.RGB = BASICCOLOR
.Name = Replace(.Name, "Flowchart: Terminator", ShapeName)
Names(i + 1) = .Name
End With
Next i
.Activate
.Shapes.Range(Names).Select
Selection.Cut
Call MangeCombinePPTFromExcel(WS, Lft, Tp)
.Range(MyRange).Select
End With 'WS
End Sub
Public Sub MangeCombinePPTFromExcel(WS As Worksheet, Lft As Single, Tp As Single)
Dim PPT As Object
Dim Pres As Object
Dim Sld As Object
Dim Shp As Shape, Rctangl As Shape, Rctangll As Shape, MergeShape As Shape
Set PPT = CreateObject("Powerpoint.Application")
Set Pres = PPT.Presentations.Add
Set Sld = Pres.Slides.Add(1, 12)
PPT.Activate
ShapeName = "ex"
With Sld
.Shapes.Paste.Select
On Error Resume Next
PPT.CommandBars.ExecuteMso ("ShapesUnion")
On Error GoTo 0
.Shapes(.Shapes.Count).Cut
End With
With WS 'back to Excel
.Paste
With .Shapes(.Shapes.Count)
.Name = ShapeName
.Left = Lft
.Top = Tp
End With
End With
PPT.Quit
End Sub
Click to see Picture
enter image description here
I have PPTs that are being generated via software that I have no control over. Upon generation, the software puts all text into TextBoxes instead of my Placeholders.
I created a script to move the text from the TextBoxes into the placeholders and this works great; however, I am unable to maintain the links and the lists are always showing as Bulleted despite some being numbers. Basically, if there is a link in the textbox, it should still be a link in the Placeholder. FYI, this script also changes shape 3 on each slide into the Title Placeholder
How can I preserve the formatting when I am moving the text over? I attempted to use pastespecial, but that still was only moving the text into the format of the placeholder.
Sub TextBoxFix()
Dim osld As Slide, oshp As Shape, oTxR As TextRange, SlideIndex As Long, myCount As Integer, numShapesOnSlide As Integer
Dim tempBulletFormat As PowerPoint.PpBulletType
For Each osld In ActivePresentation.Slides
myCount = 1
With ActivePresentation
'For Each oshp In osld.Shapes
osld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
For i = osld.Shapes.Count To 1 Step -1
Set oshp = osld.Shapes(i)
If i = 3 Then
osld.Shapes.Placeholders.Item(1).TextFrame.TextRange = oshp.TextFrame.TextRange.Characters
osld.Shapes.Placeholders.Item(1).Visible = msoTrue
oshp.Delete
ElseIf i > 3 And oshp.Type = msoTextBox Then
oshp.TextFrame.TextRange.Copy
osld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(oshp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = oshp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
oshp.Delete
End If
Next i
End With
Next osld
End Sub
This may have some formatting issues that need to be addressed, but this will insert the hyperlinks that you are looking for. Code is likely not the cleanest, but it works. You will also need to set the vba to break only on unhandled errors, or it will break in the middle of the code. See here.
Class Module - Hyper
Private shp As Shape
Private chrStart As Integer
Private hypAddr As String
Private hypText As String
Private Sub Class_Initialize()
End Sub
Public Sub InitializeWithValues(newShp As Shape, newChrStart As Integer, newHypAddress As String, newHypText As String)
Set shp = newShp
chrStart = newChrStart
hypAddr = newHypAddress
hypText = newHypText
End Sub
Public Function getShape() As Shape
Set getShape = shp
End Function
Public Function getchrStart() As Integer
getchrStart = chrStart
End Function
Public Function getHypAddr() As String
getHypAddr = hypAddr
End Function
Public Function getHypText() As String
getHypText = hypText
End Function
Class Module - hyperColl
Private myCollection As Collection
Private Sub Class_Initialize()
Set myCollection = New Collection
End Sub
Public Sub Add_Item(newHyper As Hyper)
Dim newArray() As Hyper
If Me.Exists(newHyper.getShape().Name) Then
newArray = myCollection(newHyper.getShape().Name)
ReDim Preserve newArray(0 To UBound(newArray) + 1)
Set newArray(UBound(newArray)) = newHyper
myCollection.Remove (newHyper.getShape().Name)
myCollection.Add newArray, newHyper.getShape().Name
Else
ReDim newArray(0)
Set newArray(0) = newHyper
myCollection.Add newArray, newHyper.getShape().Name
End If
End Sub
Public Function GetArray(shapeName As String) As Hyper()
GetArray = myCollection(shapeName)
End Function
Public Function Exists(shapeName As String) As Boolean
Dim myHyper() As Hyper
On Error Resume Next
myHyper = myCollection(shapeName)
On Error GoTo 0
If Err.Number = 5 Then 'Not found in collection
Exists = False
Else
Exists = True
End If
Err.Clear
End Function
Regular Module (Call it whatever you want)
Sub textBoxFix()
Dim sld As Slide
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
Set sld = ActivePresentation.Slides(1)
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
Set shp2 = sld.Shapes.Placeholders.Item(1)
bolCopy = True
ElseIf j > 3 And shp.Type = msoTextBox Then
Set shp2 = sld.Shapes.Placeholders.Item(2)
bolCopy = True
End If
If bolCopy = True Then
shp2.TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With shp2.TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
End If
shp.Delete
Next j
End Sub
I used OpiesDad's code as a starting point, and made some minor modifications. I was getting an error related to the GetArray function when textboxes didn't exist. In addition, I modified the code to run on all slides of the PPT. I also had to make some modifications to the TextBoxFix Sub because the content was being deleted, but wasn't populating in my Placeholders.
See my updates below:
Reused Class Module - Hyper
Removed "On Error GoTo 0" from the Exists Function in hyperColl
Revised TextBoxFix below:
Sub TextBoxFix()
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
For Each sld In ActivePresentation.Slides
With ActivePresentation
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.Start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
sld.Shapes.Placeholders.Item(1).TextFrame.TextRange = shp.TextFrame.TextRange.Characters
sld.Shapes.Placeholders.Item(1).Visible = msoTrue
shp.Delete
ElseIf j > 3 And shp.Type = msoTextBox Then
sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
shp.Delete
End If
Next j
End With
Next sld
End Sub