Basically, I am not much of a programmer and do a lot of drawing and diagramming in PowerPoint for education purposes. I currently use PowerPoint 2016. To increase my workflow speed, I map keyboard shortcuts to macro keys on my keyboard so I get the functionality just by hitting a key on the keyboard.
I am trying to find a macro that I can link to a keyboard shortcut allowing me to increment the rotation of the currently selected shape to … let’s say 2 degrees each time I hit the shortcut.
I'm new to ppt vba. After doing some research so far here is what I came up with. But it doesn't seem to be working.
Public Sub RotateCW2()
Dim shp As Shape
Set shp = ActiveWindow.Selection.ShapeRange(1)
shp.Rotate = shp.Rotate + 2
End Sub
Appreciate the help!
After mix and matching things arround, I think this one is working.
Sub Rotate()
With ActiveWindow.Selection.ShapeRange
.IncrementRotation 2
End With
End Sub
and it works as intended. Thanks guys for your answers.
You were almost there. Try this instead:
Public Sub RotateCW2()
Dim shp As Shape
Set shp = ActiveWindow.Selection.ShapeRange(1)
shp.Rotation = shp.Rotation + 2
End Sub
From Thomas' answer I figured I might try this.
Public Sub RotateCW2()
Dim shp As Shape
Set shp = ActiveWindow.Selection.ShapeRange(1)
shp.Rotate = shp.IncrementRotation(2)
End Sub
This time I get the error "Compole error: Expected Function or variable" and it highlights (.IncrementRotation).
The Shape Object has a series of Increment properties to choose from.
Note: Descriptions copied from MSDN
IncrementRotation( Increment )
"Specifies how far the shape is to be rotated horizontally, in degrees. A positive value rotates the shape clockwise; a negative value rotates it counterclockwise."
IncrementRotationX( Increment )
"Specifies how much (in degrees) the rotation of the shape around the x-axis is to be changed. Can be a value from ? 90 through 90. A positive value tilts the shape up; a negative value tilts it down."
IncrementRotationY( Increment )
"Specifies how much (in degrees) the rotation of the shape around the y-axis is to be changed. Can be a value from ? 90 through 90. A positive value tilts the shape to the left; a negative value tilts it to the right."
Public Sub RotateCW2()
Dim shp As Shape
Set shp = ActiveWindow.Selection.ShapeRange(1)
shp.Rotate = shp.IncrementRotation 2
End Sub
Related
I have a Powerpoint-Slide with pasted, formatted source code in the form of text shapes. Sadly the contrast of some part of that text is bad on a projector, so I would like to change every colour occurence for a specific font with a different colour. In this specific example I want to replace the orange colour:
Iterating over all shapes and accessing the whole text of a shape is not a problem, but I can't find any property that allows me to enumerate over the styled text segments:
Sub ChangeSourceColours()
For Each pptSlide In Application.ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
If (pptShape.Type = 1) And (pptShape.TextFrame.TextRange.Font.Name = "Consolas") Then
' Iterate over styled segments and change them if the previous colour is orangey
MsgBox pptShape.TextFrame.TextRange
End If
Next
Next
End Sub
The TextRange2 property looked helpful at a first glance, but looking at the variables in the debugger I see nothing that looks like a series of formatted segments. I would expect to find something like <span> in HTML to check and possibly change the colour.
The textFrame2.textRange.Font is valid for the whole text. If you want to access the single characters and their individual formatting, you need to access textRange.Characters.
The following routine changes the text color for all characters that have a specific color to a new color:
Sub ChangeTextColor(sh As Shape, fromColor As Long, toColor As Long)
Dim i As Long
With sh.TextFrame2.TextRange
For i = 1 To .Characters.Length
If .Characters(i).Font.Fill.ForeColor.RGB = fromColor Then
.Characters(i).Font.Fill.ForeColor.RGB = toColor
End If
Next i
End With
End Sub
You call it from your code with
Dim pptSlide as Slide
For Each pptSlide In Application.ActivePresentation.Slides
Dim pptShape As Shape
For Each pptShape In pptSlide.Shapes
If (pptShape.Type = 1) And (pptShape.TextFrame.TextRange.Font.Name = "Consolas") Then
ChangeTextColor pptShape, RGB(255, 192, 0), vbRed
End If
Next
Next
You will have to adapt the RGB-Code to the orange you are using, or instead of using RGB, you can use ObjectThemeColor. To avoid a type mismatch, you need to declare the pptShape variable as Shape - you should declare all your variables and use Option Explicit anyhow.
Note that you can use the ChangeTextColor-routine also in Excel (and probably also in Word). Shapes are defined similar in Excel and Powerpoint. Advantage in Excel: You can use the macro recorder to get some insights how a Shape can be used in Office VBA.
I have a PPT-Presentation with a number of charts. Each chart has data labels. These data labels are formated ##.##. I am trying to change it to ##.0 via VBA. Here is what I do:
Sub Format_Datalabels()
Dim Layout As CustomLayout
Dim Slide As Slide
Dim Shape As Shape
For Each Slide In ActivePresentation.Slides
For Each Shape In Slide.Shapes
With Shape
If .HasChart Then
With .Chart
For Each Point In .SeriesCollection(1)
.DataLabels.NumberFormat = "##.0"
End With
End If
End With
Next
End Sub
I guess, I am not actually getting a hold of the actual data labels. I am thrown the error "Method or data object not found". Any idea how I can actually format all data labels of all charts in a given presentation?
NumberFormat is poorly documented. In this context, 0 is not treated as a literal but as a special character. If there is a number in the first decimal position, then that number is displayed. If there is no number, then 0 will display, so 4 becomes 4.0, but 4.1 stays 4.1.
Normally in math, if every decimal number is 0, you don't display it at all. 4 is better than 4.0. But if you need to replace all first position decimals with 0, here's how:
.DataLabels.NumberFormat = "##"".0"""
Here, because .0 is in double double quotes, it's treated as a literal. I haven't tried debugging your code. Here's a macro that is tested as working:
Sub ChangeDataLabelNumberFormat()
With ActivePresentation.Slides(1).Shapes(1)
If .HasChart Then
With .Chart.SeriesCollection(1)
.HasDataLabels = True
.DataLabels.NumberFormat = "##"".0""" 'Displays all numbers as XX.0
End With
End If
End With
End Sub
I would like to make a macro in Powerpoint that enables me to create shapes in a similar fashion as when you select the autoshapes in the autoshape overview (i.e. once you call the macro you have a possibility to click to set the coordinates and subsequently you drag and click to set the width&height). Also, I would like to give it pre-set cosmetic characteristics (e.g. certain inner margins, fill color, border style and transparancy), which will be defined in the vba code.
I am aware of .addshapes(), however, this requires coordinates and height/width as input. Moreover, I have not find any posts / documents on vba to create shapes without defined coordinates and height/width.
Anyone some ideas on how to tackle this challenge?
Many thanks in advance!
Sofar
Building on what John Korchok suggested, here's code that retrieves the just-drawn shape so that your code can resume and manipulate it...
Sub testAppComBars()
Dim SHP As Shape
Application.CommandBars.ExecuteMso ("ShapeFreeform")
Stop
Set SHP = Selection.ShapeRange(1)
With SHP.Fill
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0.75
End With
End Sub
I would hope there's a more elegant solution than using Stop to pause code execution while the user picks the shape's location (or in this case, draws a freeform polyline/polygon), but that's all I could come up with off the top of my head.
I was fascinated by this problem and think this might help you.
Consider that when you draw a new autoshape, you have changed the window selection, and created a new selection ShapeRange with exactly 1 item (the new shape).
So by setting a WindowSelectionChange event, you're able to apply any formatting you wish at the time of creation.
First create a class module called cPptEvents with the following:
Public WithEvents PPTEvent As Application
Private Sub PPTEvent_WindowSelectionChange(ByVal sel As Selection)
On Error GoTo Errhandler
Debug.Print "IN_PPTEvent_WindowSelectionChange"
Dim oShp As Shape
If (ActiveWindow.ViewType = ppViewNormal) Then
With sel
If .Type = ppSelectionShapes Then
If .ShapeRange.Count = 1 Then
Set oShp = .ShapeRange(1)
If oShp.Type = msoAutoShape Then
If oShp.AutoShapeType = msoShapeOval Then
If oShp.Tags("new_oval") = "" Then
oShp.Fill.ForeColor.RGB = RGB(255, 0, 0)
oShp.Tags.Add "new_oval", "true"
End If
End If
End If
End If
End If
End With
End If
Exit Sub
Errhandler:
Debug.Print "Error: " & Err.Description
End Sub
This checks the selection every time it changes. If there's an oval selected, it looks for the "new_oval" tag, which will not exist for a newly created shape. In that case, it applies a red fill, although of course once you get to this point you can call an entirely different sub, pass along the shape, and do whatever you want formatting-wise to it.
By adding that "new_oval" tag, you ensure that the formatting will not be applied to an oval that hasn't been newly created. This allows the user to make manual changes to the formatting as needed -- otherwise you're just resetting the formatting every time the user selects an oval.
Note that for the _WindowSelectionChange event to be running in the background, you have to call this at some point:
Public MyEventClassModule As New cPptEvents
'
Public Sub StartMeUp()
Set MyEventClassModule.PPTEvent = Application
End Sub
You can include that one line from StartMeUp above in whatever Ribbon_Onload sub is triggered by your addin, if you're making a new addin ribbon.
With this solution, you don't even have to give the end user a special button or set of tools to create the shapes that are being formatted. It happens invisibly whenever the user draws a new shape from the native PPT tools.
This will put your cursor in drawing mode to draw an oval. After running, you may have to click on the slide once, then the cursor will change shape and you can draw an oval:
Sub DrawOval()
Application.CommandBars.ExecuteMso ("ShapeOval")
End Sub
Other commands to substitute for ShapeOval:
ShapeRectangle
ShapeElbowConnectorArrow
ShapeStraightConnectorArrow
Get the full list in Excel spreadsheets from Microsoft Office 2016 Help Files: Office Fluent User Interface Control Identifiers
Look for the powerpointcontrols.xlsx file and search the first column with "shape"
There are 173 shapes in the menu, so you have a lot of macros to write.
There seems to be a lot of information on how to ADD axis to chart however, theres not much information available if you want to DELETE/REMOVE axis from a chart.
So I have a 100% stack bar chart.
I would like to delete/remove the X axis (left to right).
I imagined that it would be something as simple as....
Chart.HasAxis(xlCategory) = False
But I get a "can't assign function call"
Not sure what code would turn the x axis off?
Any ideas?
Maybe post more of your code if this still doesn't work -- unless you have previously declared Chart as a variable and assigned a Chart to it (another problem is potentially using reserved/semi-reserved keywords for variable names), the statement you provide is at best pseudo-syntax.
What you're doing should work, fundamentally, assigning a boolean to something like ActivePresentation.Slides(1).Shapes(1).Chart.HasAxis(xlCategory) = _boolean_ should definitely work.
For example create a presentation with one slide, delete all shapes/placeholders, and then insert a stacked bar 100% chart. Then run this macro:
Sub Test()
Dim cht As Chart
Dim sld As Slide
Dim pres As Presentation
Set pres = ActivePresentation
Set sld = pres.Slides(1)
Set cht = sld.Shapes(1).Chart
If MsgBox("Should this chart have a visible category axis?", vbYesNo) = vbYes Then
cht.HasAxis(xlCategory) = True
Else:
cht.HasAxis(xlCategory) = False
End If
End Sub
I want to programmatically erase user's pen drawing and annotation over slides in PowerPoint 2003/2007/2010 as an alternative to sending "E" keystroke.
I have found that SlideShowView.EraseDrawing only erases lines made by SlideShowView.DrawLine.
Sample code:
PowerPoint.Application.ActivePresentation.SlideShowSettings.Run.View.EraseDrawing
Thanks for your answers! rjobidon
Are you looking to delete the pen drawing after they've stopped the slide show and chosen to retain the drawing? In that case, invoke the EraseInkOnSlide function below on any slide you want to erase drawings from.
Sub TestMe()
EraseInkOnSlide ActivePresentation.Slides(1)
End Sub
Sub EraseInkOnSlide(oSl As Slide)
' Erases any INK shapes drawn by the user and
' retained when the user quits the slide show
Dim oSh As Shape
Dim x As Long
With oSl.Shapes
For x = .Count To 1 Step -1
If .Item(x).Type = 23 Then
.Item(x).Delete
End If
Next
End With
End Sub
I suspect you'd hve to drop out of slide show mode momentarily then return to the current slide in slideshwo mode in order to get this to work in slide show mode; PPT apparently doesn't consider the ink shapes part of the slide's shapes collection until the user has ended the show and elected to keep the shapes. Weird.
This gives the user the option of keeping or deleting the ink, then goes back to the original slide in slide show view. STILL not what you're after, really, but it's as close as I've been able to get so far:
Private Sub CommandButton1_Click()
Dim x As Long
x = SlideShowWindows(1).View.Slide.SlideIndex
With SlideShowWindows(1)
.View.Exit
End With
With ActivePresentation
.SlideShowSettings.Run
End With
SlideShowWindows(1).View.GotoSlide (x)
End Sub