I wrote a macro to batch crop and resize the pictures in selected slides, the resize work good, but after I added the crop codes, it is not working. Please see the codes as below, is there any thing wrong? welcome and thanks suggestion.
Sub crpicture ()
Dim osld As Slide
Dim oshp As Shape
For Each osld In ActiveWindow.Selection.SlideRange
For Each oshp In osld.Shapes
oshp.PictureFormat.CropLeft = 0
oshp.PictureFormat.CropTop = 0.5 * 72
oshp.PictureFormat.CropRight = oshp.Width - oshp.Height
oshp.PictureFormat.CropBottom = 0
oshp.Height = 3 * 72
oshp.Left = 3.4 * 72
oshp.Top = 0.7 * 72
oshp.ZOrder msoSendToBack
Next
Next
End Sub
Related
I wrote code to create circles beneath selected objects in a slide.
The total shapes it can work on is limited to 100 (or whatever number I
choose).
How to set it to any value?
I tried to enter "n", "x" and others. Debug would not let it through.
More importantly, the newly created shapes seem to be aligned,
however at a closer look they need manual intervention to
correct the positioning.
The behavior does not seem consistent across files: on the .pptm
where the macro is stored the shapes are perfect circles (no matter
if the selection is made of squares or rectangles), on
another one they are distorted.
Sub CreateNewShapeAndAlign()
Dim Shp(1 To 100) As Shape
Dim Shp_Cntr As Long
Dim Shp_Mid As Long
Dim New_Shapes As Shape
Dim Ratio As Double
Dim x, y As Integer
Ratio = 1.4
Set myDocument = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber)
For Each Shp(1) In ActiveWindow.Selection.ShapeRange
Shp_Cntr = Shp(1).Left + Shp(1).Width / 2
Shp_Mid = Shp(1).Top + Shp(1).Height / 2
x = ActiveWindow.Selection.ShapeRange.Count
For y = 1 To x
If Shp(1) Is Nothing Then
Set Shp(1) = ActivePresentation.Slides.Range.Shapes(y)
Else
Set Shp(y) = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber).Shapes(y)
End If
Next y
Set New_Shape = myDocument.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - ((Shp(1).Width * Ratio) / 2), Top:=Shp_Mid - ((Shp(1).Height * Ratio) / 2), Width:=Shp(1).Width * Ratio, Height:=Shp(1).Height * Ratio)
New_Shape.Fill.ForeColor.RGB = RGB(100, 100, 100)
New_Shape.Line.Visible = msoFalse
Next
ActiveWindow.Selection.ShapeRange.ZOrder msoBringToFront
End Sub
Below the working code:
I removed any reference to the number of shapes, it was that easy
The alignment is fixed by setting the variables center and middle to
Single (as per clarification by Steve Rindsberg above)
I forced the shapes to be circles by passing the width value to the height
I further cleaned up and removed unnecessary loops I had left from previous attempts at aligning the shapes. I guess variable Ratio should be Single as well, however I don't think it matters so much as it has only two digits after the comma so there is nothing to round.
Sub CreateUnderneath()
Dim Shp As Shape
Dim Shp_Cntr As Single 'Center of Selected Shapes
Dim Shp_Mid As Single 'Middle of Selected Shapes
Dim New_Shape As Shape
Dim Ratio As Double 'Size of new shape relative to selected one underneath
Ratio = 1.45
Set myDocument = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber)
If ActiveWindow.Selection.Type = 0 Then
MsgBox "Nothing has been selected"
Else
For Each Shp In ActiveWindow.Selection.ShapeRange'.GroupItems 'to have it work inside groups
Shp_Cntr = Shp.Left + Shp.Width / 2
Shp_Mid = Shp.Top + Shp.Height / 2
' Circle
Set New_Shape = myDocument.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - ((Shp.Width * Ratio) / 2), Top:=Shp_Mid - ((Shp.Width * Ratio) / 2), Width:=Shp.Width * Ratio, Height:=Shp.Width * Ratio)
New_Shape.Fill.ForeColor.RGB = RGB(0, 0, 0)
New_Shape.Line.Weight = 0.75
New_Shape.Line.Visible = msoFalse
New_Shape.LockAspectRatio = msoTrue
New_Shape.Name = "ShepeBelow"
Next
ActiveWindow.Selection.ShapeRange.ZOrder msoBringToFront
End If
End Sub
I want to give glow/shrink animation to a text in PowerPoint using VBA.
I can not configure it to give size 110% (it takes default size 150%) & also want a smooth end to 2 sec.
I tried the scale property but did not get my result.
Set osld = ActivePresentation.Slides(1)
Set dshp = osld.Shapes("LeftText")
osld.TimeLine.MainSequence.AddEffect dshp, msoAnimEffectGrowShrink, , msoAnimTriggerWithPrevious
For C = 1 To osld.TimeLine.MainSequence.Count
Set oeff = osld.TimeLine.MainSequence(C)
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = 2
'oeff.Behaviors.Add(msoAnimTypeScale).ScaleEffect.ByY = 110
'oeff.Behaviors.Add(msoAnimTypeScale).ScaleEffect.ByX = 110
Next C
Give this a try:
Sub GlowAnimationOptions()
Dim effGrowShrink As Effect
Set osld = ActivePresentation.Slides(1)
Set dshp = osld.Shapes("LeftText")
Set effGrowShrink = osld.TimeLine.MainSequence.AddEffect(Shape:=dshp, EffectID:=msoAnimEffectGrowShrink, Trigger:=msoAnimTriggerWithPrevious)
With effGrowShrink
With .EffectParameters
.Size = 120
End With
With .Timing
.SmoothEnd = msoTrue
.Duration = 4
End With
End With
End Sub
I'm trying to explore how do I apply some formatting to only few selected words in a textbox but so far unable to accomplish this myself.
Somehow with the code I created below, I can only use it to select all the words in the textbox instead of just a few words I want.
It would be great if anyone can provide me a simpler/ existing codes that can help me solve this please ?
Thanks in advance
Sub ActiveTextRange()
Dim sld As slide
Dim sh As Shape
Dim wordcount As Long, j As Long, x As Long, y As Long, z As Long
wordcount = ActiveWindow.Selection.ShapeRange(1).textFrame.TextRange.Words.Count
With ActiveWindow.Selection.ShapeRange(1)
.textFrame.TextRange.Words(Start:=1, Length:=wordcount).Font.Color.RGB = RGB(230, 0, 0)
End With
End Sub
The following might help. Key to this is being able to track the location of the specific text you want to change in amongst larger chunks of text; my suggestion is to format each bit of text as you add it to the shape. Cheers.
Option Explicit
Sub ActiveTextRange()
Dim vPresentation As presentation
Dim vSlide As Slide
Dim vShape As Shape
Dim vAddThisText As String
' Create a new presentation, add a slide and a rectangle shape
Set vPresentation = Application.Presentations.Add
Set vSlide = vPresentation.Slides.Add(vPresentation.Slides.Count + 1, ppLayoutBlank)
Set vShape = vSlide.Shapes.AddShape(msoShapeRectangle, 10, 10, 600, 300)
' Make the shape white with a 3pt dark red border
vShape.Fill.ForeColor.RGB = rgbWhite
With vShape.Line
.ForeColor.RGB = rgbDarkRed
.Weight = 3
End With
' Setup the shape to be left aligned, font color, top anchored, etc
With vShape.TextFrame
.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextRange.Font.Color.RGB = rgbBlack
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.SpaceAfter = 6
.TextRange.ParagraphFormat.WordWrap = msoCTrue
End With
' And now format the word red, which is the 7th character and is 3 long
vAddThisText = "Hello Red World"
vShape.TextFrame.TextRange.InsertAfter vAddThisText
With vShape.TextFrame.TextRange.Characters(7, 3)
.Font.Color.RGB = rgbRed
' and change other attributes if needed etc
End With
End Sub
And the output is ...
This colors the second and third words red in a Title placeholder. After Words, the first number is the starting position and the second number is the length:
Sub ColorWords()
Dim objSlide As Slide
Dim objShape As Shape
For Each objSlide In ActivePresentation.Slides
For Each objShape In objSlide.Shapes
If objShape.Type = msoPlaceholder Then
If objShape.PlaceholderFormat.Type = ppPlaceholderTitle Or objShape.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
With objShape.TextFrame2.TextRange.Words(2, 2).Font.Fill
.Solid
.ForeColor.RGB = RGB(255, 0, 0)
End With
End If
End If
Next objShape
Next objSlide
End Sub
To color a word selection, use:
ActiveWindow.Selection.TextRange.Font.Color.RGB = RGB(Red:=255, Green:=0, Blue:=0)
OK. I think I better understand the ask ... but I'm assuming in this response you're selecting text ... rather than just a shape itself. So you're editing the powerpoint, select some text in a shape, and want to run a macro to format(?) It should be as simple as creating the following in a code module (and then I created a custom access toolbar link to run the macro at the top of PowerPoint to make it quick):
Option Explicit
Sub ActiveTextRange()
ActiveWindow.Selection.TextRange.Font.Color.RGB = rgbRed
End Sub
Before:
Select the text "Red" and run macro:
Btw ... if you want to select just the shape and have some logic choose the text, the concept is a mix of this and my first answer.
I would like to align ( in this case center)a shape( round cornered rectangle) within sharp cornered rectangle in a slide i.e the center point of both shapes should be equal using VBA without using 'Selection'.I am thinking to reference them via names(Like, wherever these two shapes come as a bunch, macro should align them) but not sure how to start.
Excuse me for the layman's explanation. Any thoughts would really be helpful and push me to start.
You'll have to set up a loop to check each shape in the slide, finding if its Type is an AutoShape, then if its AutoShapeType is msoShapeRoundedRectangle or msoShapeRectangle. As each are found, you would store the name of each in a variable. If both are found then you would get the left, top, width and height measurements for each and set those values so the centers align.
Sub CenterShapes()
Dim oSlide As Slide
Dim oShape As Shape
Dim bFoundRRect As Boolean, bFoundRect As Boolean
Dim RRectName$, RectName$
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoAutoShape Then
If oShape.AutoShapeType = msoShapeRoundedRectangle Then
bFoundRRect = True
RRectName$ = oShape.Name
End If
If oShape.AutoShapeType = msoShapeRectangle Then
bFoundRect = True
RectName$ = oShape.Name
End If
End If
Next oShape
If bFoundRRect = True And bFoundRect = True Then
RRectVCenter = oSlide.Shapes(RRectName$).Top + (oSlide.Shapes(RRectName$).Height / 2)
RRectHCenter = oSlide.Shapes(RRectName$).Left + (oSlide.Shapes(RRectName$).Width / 2)
RectVCenter = oSlide.Shapes(RectName$).Top + (oSlide.Shapes(RectName$).Height / 2)
RectHCenter = oSlide.Shapes(RectName$).Left + (oSlide.Shapes(RectName$).Width / 2)
VDif = RRectVCenter - RectVCenter
HDif = RRectHCenter - RectHCenter
oSlide.Shapes(RectName$).Top = oSlide.Shapes(RectName$).Top + VDif
oSlide.Shapes(RectName$).Left = oSlide.Shapes(RectName$).Left + HDif
End If
Next oSlide
End Sub
This example assumes you know, or determine with your code, the names of the shapes you want to align. Then it's a quick manner of setting up a ShapeRange and using the built-in alignment functions in PowerPoint.
Option Explicit
Sub AlignMe()
Dim theseShapeNames As Variant
theseShapeNames = Array("Rectangle 3", "Rectangle 4", "Rectangle 5")
Dim thisSlide As Slide
Dim theseShapes As ShapeRange
Set thisSlide = ActivePresentation.Slides(1)
Set theseShapes = thisSlide.Shapes.Range(theseShapeNames)
theseShapes.Align msoAlignCenters, msoFalse
End Sub
I am in my first week of learning VBA, and I am looking for a VBA code that will help me resize and reposition pictures pasted into PowerPoint 2016. The desired picture format details are below:
Size
- Height = 3.39"
- Width = 6.67"
- Rotation = 0
- Scale Height = 62%
- Scale Width = 62%
- Aspect Ratio = Locked
- Relative to original picture size = true
Position
- Horizontal position = 0
- Top Left Corner
- Vertical position = 2.06
- Top Left Corner
Any help would be greatly appreciated.
Below is the code that worked for me. Thanks for the support.
Sub ResizeAll()
For Each tSlide In ActiveWindow.Presentation.Slides
tSlide.Select
With tSlide.Shapes.Item(1)
'assume a blank slide with one image added only
.Select
.Height = 72 * 3.39
.Width = 72 * 6.67
'algin middle (Horizontal Center)
.Left = 0
.Top = ActivePresentation.PageSetup.SlideHeight / 3.25
End With
Next
End Sub
Okay, so this macro will adjust the details of every picture within your powerpoint.
Sub AdjustImages()
Dim curSlide As Slide
Dim curShape As Shape
For Each curSlide In ActivePresentation.Slides
For Each curShape In curSlide.Shapes
With curShape
'size:
''1 inch = 72 points
.Height = 72 * 3.39
.Width = 72 * 6.67
.ScaleHeight 0.62, msoTrue
.ScaleWidth 0.62, msoTrue
.LockAspectRatio = msoTrue
'position:
.Rotation = 0
.Left = 0
.Top = 2.06
'Relative to original picture size = true
End With
Next curShape
Next curSlide
End Sub
The only part of your question that I don't really understand is when you mention it being "relative to original picture size = true". I can't seem to find an attribute that matches that.