I am trying to edit a table in a slide, and I am using this code. Can someone please tell me why it isn't working? If instead of s.Shapes.Table I have s.Shapes.Range for example it works fine.
Sub format()
Dim s As Slide
For Each s In ActivePresentation.Slides
With s.Shapes.Table
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 30
End With
Next s
End Sub
Like so instead:
Sub format()
Dim s As Slide
Dim oSh As Shape
Dim oTbl As Table
Dim lRow As Long
Dim lCol As Long
For Each s In ActivePresentation.Slides
' If you choose Debug | Compile, this next line fails
' There's no such property as .Table
' With s.Shapes.Table
For Each oSh In s.Shapes
If oSh.HasTable Then
Set oTbl = oSh.Table
For lRow = 1 To oTbl.Rows.Count
For lCol = 1 To oTbl.Columns.Count
With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
.Font.Name = "Arial"
.Font.Size = 30
End With
Next
Next
End If
Next ' Shape
Next s
End Sub
Related
I am trying to copy all true or checked boxes on all slides and paste them onto one slide within my presentation. I can't seem to figure it out. Below is the code that I am using. Any help is appreciated.
`Sub ckbxCopy()
Dim shp As Shape
Dim sld As Slide
Dim i As Integer
On Error Resume Next
For Each sld In ActivePresentation.Slides
For i = 1 To 4
shp = ActivePresentation.Slides("CheckBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
If shp.OLEFormat.Object.Value = True Then
shp.Copy
ActivePresentation.Slides(3).Shapes.Paste
End If
End If
Next i
Next sld
End Sub`
This works for me:
Sub ckbxCopy()
Dim shp As Shape, pres As Presentation
Dim sld As Slide, sldDest As Slide
Dim i As Integer, t As Long
Set pres = ActivePresentation
Set sldDest = pres.Slides(3) 'where shapes are to be pasted
sldDest.Shapes.Range.Delete 'remove existing shapes
t = 20
For Each sld In pres.Slides
If sld.SlideIndex <> sldDest.SlideIndex Then
For i = 1 To 4
Set shp = Nothing
Set shp = SlideShape(sld, "CheckBox" & CStr(i))
If Not shp Is Nothing Then
If shp.OLEFormat.Object.Value = True Then
shp.Copy
pres.Slides(3).Shapes.Paste.Top = t 'paste and position
t = t + 20
End If
End If
Next i
End If
Next sld
End Sub
'Return a named shape from a slide (or Nothing if the shape doesn't exist)
Function SlideShape(sld As Slide, shapeName As String) As Shape
On Error Resume Next
Set SlideShape = sld.Shapes(shapeName)
End Function
I have an issue aligning shapes using VBA on PowerPoint (office 360).
I know I can use .Shapes.Range.Align msoAlignBottom, msoFalse
but I don't understand how to make it work with a specific shape name as I always have an error or nothing is happening.
This is the code in which I would like to implement this action:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
On Error Resume Next
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSh.Shapes.Range.Align msoAlignBottom, msoTrue
End Select
End If
Next oSh
Next oSl
End Sub
Thank you very much for your help,
Try this code:
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
'sn = InputBox("Enter the name of the shape")
sn = "Name1" 'debug
'On Error Resume Next
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.Type 'placeholder or not placeholder?
Case msoPlaceholder
' it's a placeholder! check the placeholder's type
If oSh.PlaceholderFormat.Type = ppPlaceholderTitle _
Or oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
'do smth with placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape
End If
Case Else 'it's not a placeholder
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I also recommend removing the On Error Resume Next statement because it hides errors and you don't get useful information about how the code works.
You have to create a ShapeRange that includes the shapes you want to align. Since you are keying off the name of the shape, the example below shows how a wildcard can be used.
Option Explicit
Sub Test()
LineUpShapes 1, "Rectangle", msoAlignTops
End Sub
Sub LineUpShapes(ByVal SlideNumber As Long, _
ByVal ShapeName As String, _
ByVal alignment As MsoAlignCmd)
Dim sl As Slide
Set sl = ActivePresentation.Slides(SlideNumber)
Dim namedShapes() As Variant
Dim shapeCount As Integer
Dim sh As Shape
For Each sh In sl.Shapes
If sh.Name Like (ShapeName & "*") Then
shapeCount = shapeCount + 1
ReDim Preserve namedShapes(shapeCount) As Variant
namedShapes(shapeCount) = sh.Name
Debug.Print "shape name " & sh.Name
End If
Next sh
Dim shapesToAlign As ShapeRange
Set shapesToAlign = sl.Shapes.Range(namedShapes)
shapesToAlign.Align alignment, msoFalse
End Sub
Thank you so much Алексей!
I have readapted your code and it works perfectly! It is always a placeholder in my case ;)
Sub FixFitToShape()
Dim oSl As Slide
Dim sn As String
Dim oSh As Shape
sn = InputBox("Enter the name of the shape")
For Each oSl In ActivePresentation.Slides
For i = 1 To oSl.Shapes.Count
Set oSh = oSl.Shapes(i)
If oSh.Name = sn Then
Select Case oSh.PlaceholderFormat.Type
Case 1, 3 'Title
oSh.TextFrame2.AutoSize = msoAutoSizeTextToFitShape ' OR msoAutoSizeNone
Case 2, 7 'Text / Content
oSh.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
oSl.Shapes.Range(i).Align msoAlignBottoms, msoTrue 'align it to bottom of the slide
End Select
End If
Next
Next oSl
End Sub
I want a macro that loops through all the slides and change the text in a table to black. When I try the code below, I get the error message: Method 'Table' of 'Shape' failed.
This is my code:
Sub TableAllBlack()
Dim lRaw As Integer
Dim lCol As Integer
Dim oTbl As Table
Dim osld As Slide
Dim oShp As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
Set oTbl = oSh.Table
With oTbl
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
With .Cell(lRow, lCol).Shape
If .HasTextFrame Then
If .TextFrame.HasText Then
TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End If
End If
End With
Next
Next
End With
Next
Next
End With
End Sub
Not every shape has a Table associated with it. Just add the statement If oSh.HasTable Then... And it should work
This If statement should be placed to encapsulate all of the Table calls, so place it directly before the Set oTbl = oSh.Table line
I am trying to edit a table in a slide, and I am using this code but it takes a lot of time to complete.
For lRow = 1 To oTbl.Rows.Count
For lCol = 1 To oTbl.Columns.Count
With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
.Font.Name = "Arial"
.Font.Size = 30
End With
Next
Next
Maybe this code can help you. It will change format in each table of active presentation. You just have to update Font Name and Font Size.
Sub format()
Dim s As Slide
Dim oSh As Shape
Dim oTbl As Table
Dim lRow As Long
Dim lCol As Long
For Each s In ActivePresentation.Slides
For Each oSh In s.Shapes
If oSh.HasTable Then
Set oTbl = oSh.Table
For lRow = 1 To oTbl.Rows.Count
For lCol = 1 To oTbl.Columns.Count
With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
.Font.Name = "Batang"
.Font.Size = 16
End With
Next
Next
End If
Next
Next s
End Sub
I have a current macro that works well. It deletes all of the current notes in the PPT slide - then copies every shape that has text to the slide notes.
I need one more "tweak"--- when the text is copied to the note area, I need to also copy the current font, font color, size, etc.
Is there a way to do this?
Many thanks!!!
Sub Copy_SlideShapeText_ToNotes()
Dim curSlide As Slide
Dim curShape As Shape
Dim curNotes As Shape
Dim oSh As Shape
'delete all notes in receiving slides
For Each curSlide In ActivePresentation.Slides
curSlide.NotesPage.Shapes(2) _
.TextFrame.TextRange = ""
Next curSlide
For Each curSlide In ActivePresentation.Slides
For Each oSh In curSlide.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
Set curNotes = oSh
Exit For
End If
Next oSh
For Each curShape In curSlide.Shapes
If curShape.TextFrame.HasText Then
curNotes.TextFrame.TextRange.InsertAfter curShape.TextFrame.TextRange.Text & vbCr
End If
Next curShape
Next curSlide
End Sub
Sub Example()
' Assume you have two rectangles on slide 1 and no other shapes
' And that the first rectangle has text with various formatting
' This will pick up the text from the first rectangle, run by run,
' and apply the text AND its formatting to the second rectangle
Dim oSrc As Shape
Dim oTgt As Shape
Dim x As Long
Dim oRng As TextRange
Set oSrc = ActivePresentation.Slides(1).Shapes(1)
Set oTgt = ActivePresentation.Slides(1).Shapes(2)
With oSrc.TextFrame.TextRange
For x = 1 To .Runs.Count
With .Runs(x)
' Add the text from the current run to the second rectangle
' and get a reference to its range in oRng
Set oRng = oTgt.TextFrame.TextRange.InsertAfter(.Text)
' now format the text in oRng to match the same range
' from the original
oRng.Font.Name = .Font.Name
oRng.Font.Bold = .Font.Bold
oRng.Font.Color = .Font.Color
' add other properties as required, stir well
End With
Next
End With
End Sub
Sub Copy_SlideShapeText_ToNotes()
Dim curSlide As Slide
Dim curShape As Shape
Dim curNotes As Shape
Dim oSh As Shape
' New variable:
Dim oRng As TextRange
'delete all notes in receiving slides
For Each curSlide In ActivePresentation.Slides
curSlide.NotesPage.Shapes(2) _
.TextFrame.TextRange = ""
Next curSlide
For Each curSlide In ActivePresentation.Slides
For Each oSh In curSlide.NotesPage.Shapes
If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
Set curNotes = oSh
Exit For
End If
Next oSh
For Each curShape In curSlide.Shapes
If curShape.TextFrame.HasText Then
Set oRng = curNotes.TextFrame.TextRange.InsertAfter(curShape.TextFrame.TextRange.Text)
With oRng
.Font.Name = curShape.TextFrame.TextRange.Font.Name
.Font.Bold = curShape.TextFrame.TextRange.Font.Bold
.Font.Color.RGB = curShape.TextFrame.TextRange.Font.Color.RGB
' other properties as required
End With
End If
Next curShape
Next curSlide
End Sub