I want to write a powerpoint macro where if my text colour is blue it will change the text size in shape. Not sure if it is possible? Appreciate your comments on the same
Sub thing()
Dim oSh As Shape
Dim oSl As Slide
Dim RGBColor As Long
' Change this as needed
RGBColor = RGB(255, 0, 0)
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange
If .Font.Color.RGB = RGB(255, 0, 0) Then
.Font.Size = 12
End If
End With
End If
End If
Next
Next
End Sub
Or to change just the selected shape:
Sub ChangeFontByColor()
Dim oSh As Shape
Dim RGBColor As Long
' Change this as needed
RGBColor = RGB(255, 0, 0)
Set oSh = ActiveWindow.Selection.Shaperange(1)
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange
If .Font.Color.RGB = RGB(255, 0, 0) Then
.Font.Size = 12
End If
End With
End If
End If
End Sub
Related
I need to change the colors of autoshapetypes which are connected to datalabels within a chart.
I have this code to format the chart but i cant find the code to change the autoshapetype color.
Sub Format_linechart_smoothlines()
Dim sld As Slide
Dim shp As Shape
Dim chart As chart
Dim sr As Series
Dim i As Long
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.Smooth = True
sr.Format.Line.Weight = 3
sr.HasDataLabels = True
sr.DataLabels.Position = xlLabelPositionCenter
sr.DataLabels.Font.Color = RGB(255, 255, 255)
sr.DataLabels.Font.Size = 10
sr.DataLabels.Format.AutoShapeType = msoShapeRectangle
Next i
End If
Next shp
End Sub
I've also tried to change the color of the shape in a different macro but it doesn't change the colors of the shapes within the chart:
Sub ChangeRectangleShapes_Color()
Dim sld As Slide
Dim shp As Shape
Set sld = Application.ActiveWindow.View.Slide
For Each shp In sld.Shapes
If shp.AutoShapeType = msoShapeRectangle Then
shp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End If
Next shp
End Sub
To set the fill color for your data labels, try...
sr.DataLabels.Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Change the color as desired.
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
In PPT VBA, I'm trying to change all shapes in a file that are in one accent color to another. I supply the values from this form to my function, but its not accepting the OldColor and NewColor (themecolors) as msoThemeColorAccent1 but only takes as 15 instead. but it is accepting when I give msoThemeColorAccent1 for Fill.ForeColor.ObjectThemeColor; just not accepting when supplied from the function arguments. can anybody please suggest a solution?
this is my form:
these are my code blocks:
Private Sub cmdApply_Click()
ReplaceColors cboOldColor.Value, cboNewColor.Value, cboOldTint.Text, cboNewTint.Text
End Sub
Sub ReplaceColors(OldColor As Variant, NewColor As Variant, OldTint As String, NewTint As String)
Dim i As Integer
Dim t As Integer
Dim oSld As Slide
Dim oShp As Shape
Dim x, y As Integer
Dim sBrightness
Dim oColor, nColor As ThemeColor
Dim oPP As Placeholders
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
'groups
If oShp.Type = msoGroup Then
'not groups
Else
With oShp 'other shapes
' Fill
If .Fill.ForeColor.ObjectThemeColor = OldColor And .Fill.ForeColor.Brightness = OldTint Then
.Fill.ForeColor.ObjectThemeColor = NewColor
.Fill.BackColor.Brightness = NewTint
End If
' Line
If Not .Type = msoTable Then
If .Line.Visible = msoTrue Then
If .Line.ForeColor.ObjectThemeColor = OldColor And .Line.ForeColor.Brightness = OldTint Then
.Line.ForeColor.ObjectThemeColor = NewColor
.Line.ForeColor.Brightness = NewTint
End If
End If
End If
' Text
If .HasTextFrame Then
If .TextFrame.HasText Then
For y = 1 To .TextFrame.TextRange.Runs.count
If .TextFrame.TextRange.Runs(y).Font.Color.ObjectThemeColor = OldColor And .TextFrame.TextRange.Runs(y).Font.Color.Brightness = OldTint Then
.TextFrame.TextRange.Runs(y).Font.Color.ObjectThemeColor = NewColor
.TextFrame.TextRange.Runs(y).Font.Color.Brightness = NewTint
End If
Next
End If
End If
End With
End If
'oShp = Nothing
Next oShp
Next oSld
End Sub
trying to change the color of different bullets across a presentation. Bullets have different shapes. Always the error code -2147024809 appears.
Do you see what should be changed? Thank you very much for any help!
Sub ReplacebulletColors()
Dim lFindColor As Long
Dim lReplaceColor As Long
Dim oSl As Slide
Dim oSh As Shape
Dim x As Long
lFindColor = RGB(1, 98, 155)
lReplaceColor = RGB(192, 0, 0)
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .TextFrame.TextRange.ParagraphFormat.Bullet.Font.Color.RGB = lFindColor Then
.TextFrame.TextRange.ParagraphFormat.Bullet.Font.Color.RGB = lReplaceColor
End If
End With
Next
Next
End Sub
I have a PowerPoint with notes for each slide. For each slide, I want to copy the notes, create a yellow rectangle with black border, and paste the notes into the rectangle.
I started "splicing" a macro together. Here is what I have so far. It works but rectangle is at the top (need at bottom) and not sure how to copy and paste the notes into the rectangle:
Dim oPPT As Presentation
Dim oSlide As Slide
Dim r As Integer
Dim i As Integer
Dim shapectr As Integer
Dim maxshapes As Integer
Dim oShape As Shape
Set oPPT = ActivePresentation
For i = 1 To oPPT.Slides.Count
For shapectr = 1 To oPPT.Slides(i).Shapes.Count
ActiveWindow.View.GotoSlide i
Set oShape = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 575.5, 9.12, 124.75, 34.12)
oShape.Fill.ForeColor.RGB = RGB(255, 255, 204)
oShape.Fill.BackColor.RGB = RGB(137, 143, 75)
With oShape
With .TextFrame.TextRange
.Text = "TEST"
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With
End With
Next shapectr
Next i
I need to replace "TEST" with the text that is in the notes area of the slide (could be several sentences).
I appreciate your help!
Sub addShp()
Dim osld As Slide
Dim oshp As Shape
Dim oTR As TextRange
For Each osld In ActivePresentation.Slides
On Error Resume Next
osld.Shapes("NOTES").Delete
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 10, 400, 400, 100)
oshp.Name = "NOTES"
oshp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
oshp.Fill.ForeColor.RGB = RGB(255, 255, 204)
oshp.Line.ForeColor.RGB = RGB(0, 0, 0)
With oshp.TextFrame.TextRange
If Not getNotes(osld) Is Nothing Then .Text = getNotes(osld).Text
.Font.Name = "Arial"
.Font.Size = 10
.Font.Color.RGB = vbBlack
End With
oshp.Top = ActivePresentation.PageSetup.SlideHeight - oshp.Height
Next osld
End Sub
Function getNotes(osld As Slide) As TextRange
' usually shapes(2) but not always
Dim oshp As Shape
For Each oshp In osld.NotesPage.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
If oshp.TextFrame.HasText Then
Set getNotes = oshp.TextFrame.TextRange
End If
End If
End If
Next oshp
End Function
See if this is closer
I figured out the "tweaks" I needed to left justify the text and specify a set height. Here is the final code:
Dim osld As Slide
Dim oshp As Shape
Dim oTR As TextRange
For Each osld In ActivePresentation.Slides
On Error Resume Next
osld.Shapes("NOTES").Delete
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 20, 400, 400, 300)
oshp.Name = "NOTES"
oshp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
oshp.Fill.ForeColor.RGB = RGB(255, 255, 204)
oshp.Line.ForeColor.RGB = RGB(0, 0, 0)
oshp.Line.Weight = 1.5
With oshp.TextFrame.TextRange
If Not getNotes(osld) Is Nothing Then .Text = getNotes(osld).Text
.Font.Name = "Arial"
.Font.Size = 14
.Font.Color.RGB = vbBlack
.ParagraphFormat.Alignment = msoAlignLeft
End With
oshp.Width = 717
If oshp.Height < 105 Then
oshp.Height = 105
End If
oshp.Left = 1
oshp.Top = ActivePresentation.PageSetup.SlideHeight - oshp.Height
Next osld
End Sub
Function getNotes(osld As Slide) As TextRange
' usually shapes(2) but not always
Dim oshp As Shape
For Each oshp In osld.NotesPage.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
If oshp.TextFrame.HasText Then
Set getNotes = oshp.TextFrame.TextRange
End If
End If
End If
Next oshp
End Function
Many thanks for your help!!!