I'm trying to delete tables from the active slide in a ppt presentation, but I can only get it to work if I specify the number for the slide. I want this to work for whatever slide is active, not a specific slide. The below code is set to delete tables from slide 3.
Sub CopytoPPT()
Dim rng As Excel.Range
Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
Dim i As Long, j As Long
Set ppt = GetObject(, "PowerPoint.Application")
Set pr = ppt.Presentations(1)
Set sl = pr.Slides(3)
For i = sl.Shapes.Count To 1 Step -1
' ADD THIS TEST
If IsTable(sl.Shapes(i)) Then
sl.Shapes(i).Delete
End If
Next i
End Sub
Function IsTable(oSh As Variant) As Boolean
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoTable Then
IsTable = True
End If
Else
If oSh.HasTable Then
IsTable = True
End If
End If
End Function
Change:
Set sl = pr.Slides(3)
To:
Set sl = ppt.ActiveWindow.View.Slide
Related
I'm trying to turn off gradient fill in all shapes in a PowerPoint document (including groups and sub groups).
The thing is I can't even get to cycle through the shapes correctly
Sub solid()
Set myDocument = ActivePresentation.Slides(1)
For Each sh In myDocument.Shapes
sh.Fill.solid
Next
End Sub
Thanks for your help.
Sub solid()
Dim mydocument As Presentation
Set mydocument = ActivePresentation
Dim sh As Shape
Dim sl As Slide
For Each sl In mydocument.Slides
For Each sh In sl.Shapes
If HasGradient(sh) = True Then
sh.Fill.solid
End If
Next
Next
End Sub
And also implement this function from TheSpreadSheetGuru to check whether the shape has a gradient value.
Function HasGradient(shp As Shape) As Boolean
'PURPOSE: Determine if a shape object contains a gradient format property
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim GradientStopCount As Long
'Test for Gradient Stops
On Error Resume Next
GradientStopCount = shp.Fill.GradientStops.Count
On Error GoTo 0
'Results
If GradientStopCount <> 0 Then
HasGradient = True
Else
HasGradient = False
End If
End Function
I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub
I am having trubbles with a VBA project. My goal is to make a powerpoint from an excel. Each line in the excel make a new slide, and all info are automatically placed.
All rows have the same column number.
Only one sheet in workbook, so no problem with Activesheet.name.
I have pictures and text in random order, this is why I used ppPastedefault for the type of the shape.
Some cells can be empty, this is why I used the on error.
Program launch, you chose the slide template. Then, fo each cells of the first row from excel, you place the shape (text or picture) where you want on the powerpoint slide. Positions are saved in arrays. When all shapes from the first row are placed into the slide, it automatically make all the others slides (all shapes are placed in good position).
this is working "fine", but random errors appears :
Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
'define row, column and choice of the ppt layout. Also dimensioning the Arrays'
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
For Each Cell In Plage
'Loop through all rows'
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
End With
Y = Y + 1
'Loop through all columns of each rows'
For x = 0 To Ncol - 1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'On error is used to pass cells that are empty. Maybe I could test ExcRng instead, but can't make it work'
On Error GoTo suite:
'the problem should be around here i guess'
ExcRng.Copy
DoEvents
PPTSlide.Shapes.PasteSpecial DataType:=0
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
'If statement, if this is the first slide, then you place all shape one by one. If not, all shapes are placed automatically with, "copying" the first slide'
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
End If
suite:
On Error GoTo -1
Application.CutCopyMode = False
Next x
Next Cell
End Sub
I have 2 issues with the program, and i can't solve those :
sometime, the shape (text) are not in a textbox but are in a table shape, keeping format from excel.
sometime, shapes (both text or picture) are missing
This is completly random.
On other topics, solutions are :
put a Doevents after the copy, this is not working very well. This might have improve stability, but I still have errors.
put a Application.wait for 1 or 2 seconde, not working and this solution is not good for me.
put a Application.CutCopyMode = False after the shapes.pastespecial, also not working.
That's all I could do. Maybe I have a problem into the definition of shapes,slides or even the object myShapeis badly defined, but as the failure is random, this is very hard to control.
Any idea ?
Thanks in advance for the help,
In case someone has the same issue, I think this solve the problem :
For each cell, I check if it contains picture and if it is empty or not.
If it contains a picture, it is copied with DataType:=ppPasteDefault
If it is not empty, it is copied with DataType:=ppPasteText
If it is empty, it is copied with DataType:=ppPasteEnhancedMetafile
So the loop go through everything, even empty cells and does not need the error handler anymore.
Now, you can use the error handler to restart the loop if there is an error in the copy/paste process. This is not the most beautiful solution, but it is working so far.
However, if something is going wrong, the program will loop indefinitely... you have to declare all your shapes / object / text / picture well and use dataType:= correctly.
`Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim cshape As Shape
Dim cflag As Boolean
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Dim Eshape As Shape
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
On Error GoTo reprise:
For Each Cell In Plage
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
'DoEvents'
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
'DoEvents'
End With
Y = Y + 1
For x = 0 To Ncol - 1
reprise:
On Error GoTo -1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'DoEvents'
ExcRng.Copy
DoEvents
cflag = False
For Each cshape In Wks.Shapes
If cshape.TopLeftCell.Address = Wks.Cells(Cell.Row, x + 1).Address Then
cflag = True
GoTo suite:
End If
Next
suite:
If cflag Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteDefault
'DoEvents'
Else
If Wks.Cells(Cell.Row, x + 1) <> 0 Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteText
'DoEvents'
Else
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'DoEvents'
End If
End If
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
'DoEvents'
End If
Application.CutCopyMode = False
Next x
Next Cell
End Sub`
Thanks,
So I have a macro to search all texts on a document and convert them all to curves. This macro also would look through powerclip which is out of range of CQL.
Below is my code:
Public Sub convertText()
Dim pg As Page
Dim shRange As ShapeRange
Dim sh As Shape
For Each pg In ActiveDocument.Pages
pg.Activate
Set shRange = FindAllPCShapes.Shapes.FindShapes(Query:="#type='text:artistic' or #type='text:paragraph'")
For Each sh In shRange
sh.ConvertToCurves
Next sh
Next pg
End Sub
Function FindAllPCShapes(Optional LngLevel As Long) As ShapeRange ' Shelby's function
Dim s As Shape
Dim srPowerClipped As New ShapeRange, srJustClipped As New ShapeRange
Dim sr As ShapeRange, srAll As New ShapeRange
Dim bFound As Boolean, i&
bFound = False
If ActiveSelection.Shapes.count > 0 Then
Set sr = ActiveSelection.Shapes.FindShapes()
Else
Set sr = ActivePage.Shapes.FindShapes()
End If
i = 0
Do
For Each s In sr.Shapes.FindShapes(Query:="!#com.powerclip.IsNull")
srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
Next s
If srPowerClipped.count > 0 Then bFound = True: i = i + 1
If i = LngLevel And bFound Then Set FindAllPCShapes = srPowerClipped: Exit Function
bFound = False
srAll.AddRange sr
sr.RemoveAll
sr.AddRange srPowerClipped
If LngLevel = -1 Then srJustClipped.AddRange srPowerClipped
srPowerClipped.RemoveAll
Loop Until sr.count = 0
If LngLevel = -1 Then
Set FindAllPCShapes = srJustClipped
Else
Set FindAllPCShapes = srAll
End If
End Function
It works fine on some cases, but I caught an error on some document where For Each sh In shRange will generate an error "The Referenced Object no longer exists". Apparently this is because of a nested group inside a powerclip.
I tried to ignore the error by adding On Error Resume Next and the macro will runs fine. But of course I want to know what's the error with my code so I can avoid future troubles, I rather not to ignore all the errors on my macro.
Here's a sample document to demonstrate the error.
https://www.dropbox.com/s/lpi568eoltc8cxy/ReferenceError.cdr?dl=0
Thank you
The error I think encountered is due to Nothing is returned by the FindShapes method.
Before the For loop, you should check if it's Nothing:
For Each pg In ActiveDocument.Pages
pg.Activate
Set shRange = FindAllPCShapes.Shapes.FindShapes(Query:="#type='text:artistic' or #type='text:paragraph'")
If Not shRange Is Nothing Then
For Each sh In shRange
sh.ConvertToCurves
Next sh
End If
Next pg
Ok, here is what I am looking for (Im new, so be gentle):
Copy and paste (default format) from excel to powerpoint (from just the one sheet)
I can only fit so many rows in ppt - so after a slide fills, I want ppt to create a new slide
Same title for each slide is fine!
I only need columns B:K copied over
That's it, however I am stuck :( I know the below code is NOT the best way to write this and it contains errors in which I am sure will be easy to spot. I cannot find how to do this anywhere on the net.
This is what I have so far:
Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim i As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
For i = 1 To 6
'need to set focus to slde 1
PowerPointApp.ActiveWindow.View.GotoSlide (1)
'Deletes Title
'mySlide.Shapes.Title.Delete
'builds new title
mySlide.Shapes.AddShape Type:=msoShapeRectangle, left:=9, Top:=6, Width:=702, Height:=30
mySlide.Shapes(mySlide.Shapes.Count).Line.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Size = 20
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Text = "Current Full Initiative Details – Branded Book as of " & Date
mySlide.Shapes(mySlide.Shapes.Count).Name = "I am TITLE"
mySlide.Shapes(mySlide.Shapes.Count).Line.ForeColor.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).Line.Weight = 1
mySlide.Shapes(mySlide.Shapes.Count).Fill.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).Fill.ForeColor.RGB = RGB(255, 255, 255)
'Copy Range from Excel
Set rng = ActiveWorkbook.Worksheets("RAW").Range("B1:K23")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PowerPointApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShapeRange.left = 10
myShapeRange.Top = 42
myShapeRange.Height = 492
myShapeRange.Width = 702
ActiveWorkbook.Sheets("RAW").Rows("2:23").Delete
Call myPresentation.Slides.Add(1, PpSlideLayout.ppLayoutTitleOnly)
'Clear The Clipboard
Application.CutCopyMode = False
Next i
End Sub
As requested in comments, here is the code I use to copy a slide from a master PPT template to the report PPT.
There is some extraneous code in there to provide status updates on the form we use to drive the process, as well as a debugging flag that I can toggle on/off at run time - these can both be removed.
This will serve as a starting point to finding the proper solution for your situation, and is not a complete answer to the question as asked.
'I've chosen to declare these globally, though it's probably not the best way:
Dim PPTObj As PowerPoint.Application
Dim PPTMaster As PowerPoint.Presentation
Dim PPTClinic As PowerPoint.Presentation
Private Sub InsertPPT(ByVal SlideName As String, ByVal StatusText As String)
Dim Shp As PowerPoint.Shape
Dim Top As Single
Dim Left As Single
Dim Height As Single
Dim width As Single
PPTMaster.Slides(SlideName).Copy
PPTClinic.Slides.Paste
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT"
With PPTClinic.Slides(PPTClinic.Slides.count)
If Debugging Then
.Select
End If
.Design = PPTMaster.Slides(SlideName).Design 'this ensures we get all the right formatting - only seems to be necessary 1 time, but we'll just do it on all
.ColorScheme = PPTMaster.Slides(SlideName).ColorScheme
.FollowMasterBackground = PPTMaster.Slides(SlideName).FollowMasterBackground
For Each Shp In .Shapes 'loop through all the shapes on the slide
If Debugging Then
' .Select
Shp.Select
End If
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT-" & Shp.Name
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
ReLinkShape Shp, TempVars!NewXLName
'need to store off top, left, width, height
Top = Shp.Top
Left = Shp.Left
Height = Shp.Height
width = Shp.width
Shp.LinkFormat.Update 'and force the link to refresh
MySleep 2, "S" 'hopefully, the 2 second pause will allow everything to update properly before moving on.
'then reset them here - they seem to change shape when I update them
Shp.LockAspectRatio = msoFalse
Shp.Top = Top
Shp.Left = Left
Shp.width = width
Shp.Height = Height
ElseIf Shp.Name = "SlideName" And Not Debugging Then 'if it's the "SlideName" tag
Shp.Delete 'delete it (unless we're debugging)
End If
Next
End With
Form_Master.ProcessStatus.Value = StatusText
End Sub
Private Sub ReLinkShape(ByRef Shp As PowerPoint.Shape, ByVal NewDestination As String)
Dim Link() As String
Dim link2() As String
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
Link = Split(Shp.LinkFormat.SourceFullName, "!") 'update the link to point to the new clinic spreadsheet instead of the master
If InStr(1, Link(2), "]") > 0 Then
link2 = Split(Link(2), "]")
Link(2) = "[" & TempVars!ClinicName & ".xlsx]" & link2(1)
End If
Shp.LinkFormat.SourceFullName = NewDestination & "!" & Link(1) & "!" & Link(2)
End If
End Sub
Public Sub MySleep(ByRef Unit As Double, ByRef UOM As String)
Dim Pause As Date
Pause = DateAdd(UOM, Unit, Now())
While Now < Pause
DoEvents
Wend
End Sub