I have a piece of code that only works when there are many check boxes. However when I only have one checkbox the code bugs. Basically what I want the macro to do is to select the ckeckbox as an object and align it to a cell it should also work if more than one checkbox. Could you please help?
Many thanks in advance. Please see code attached
Worksheets("Analysis Line Cupboards by Pick").CheckBoxes.Select
Selection.ShapeRange.Align msoAlignCenters, msoFalse
Selection.ShapeRange.IncrementLeft 45
Range("A10000").Select
You can align a checkbox (or any shape) on another shape, or on a cell with the left property.
Example, for an ActiveX checkbox in a Sheet to be aligned on cell B5:
Sheets("Sheet1").Shapes("Checkbox_1").Left = Sheets("Sheet1").Range("B5").Left
In your case (adapt it):
Sheets("Analysis Line Cupboards by Pick").Shapes("Checkbox name").Left = cell.left
Or, if you have multiple checkboxes, give them appropriate names and loop through them. For example, their names could be chbx_A, chbx_Hello, chbx_10 or something.
Sub AlignCHBX()
dim shp as shape
for each shp in Sheets("Analysis Line Cupboards by Pick").Shapes
if shp.name like "chbx*" then shp.left = Sheets("Analysis Line Cupboards by Pick").Range("B1").Left
next
End sub
This verifies that the shape's name starts with chbx to avoid moving other shapes. You can use this to differentiate certain groups of checkboxes, as well!
For a NON-ActiveX checkbox, use the following syntax to refer to it's left, for example:
Sheets("Sheet1").OLEObjects("chbx_A").Left
For it's value:
Sheets("Sheet1").OLEObjects("chbx_A").Object.Value
For .Top it works the same way. The .Left and .Top properties are numeric values measured in pixels. If you want to go to an absolute position, you can write Sheets("Sheet1").OLEObjects("chbx_A").Left = 150 for example. When you are making the shape's Left = to the cell's left, the code actually goes to see what Absolute value the left position of the cell is, and gives it to that shape. If I can elaborate, you could write:
dim nbPosition as Double
nbPosition = ActiveSheet.Range("B5").Left
debug.print nbPosition 'It could say 40, for example, depending on column width
ActiveSheets.Shapes("Shape1").Left = nbPosition + 10 'Will send it 10 pixels further than nbPosition
Related
To give the context of my problem, I have to work with documents with text boxes, these text boxes hide the whole sentence almost all the time, so I have to resize the text box by hand so that the text is visible. The problem is that on some documents there are over 700 text boxes. Then later I've found that i can do this (Resize shape to fit text in EN) :
So I was wondering if there is a way to select all the text boxes and resize them automatically selecting this option with VBA. Thank you !
EDIT
So I've tried to start my code doing this :
Dim eShape As Word.shape
Dim i As Long
For i = ActiveDocument.Shapes.Count To 1 Step -1
Set eShape = ActiveDocument.Shapes(i)
Then I start the condition by checking the object type in this case TextBox with
If eShape.Type = msoTextBox Then
But for the rest I didn't found the method to resize the element.
Salut Satanas,
Assembled this from various bits of code found lying around several sites:
Sub AllTextBoxesAutoSize()
Dim MyShape As Shape
For Each MyShape In ActiveDocument.Shapes
If MyShape.Type = msoTextBox Then
MyShape.TextFrame.AutoSize = True
End If
Next
MsgBox ("All text boxes autosized!")
End Sub
I added the MsgBox because otherwise it's not apparent that anything's happened :-)
Bon courage!
Steve
#TimothyRylatt If you don't want to help, then just scroll by.
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'm trying to make a button that when clicked, will add two text boxes to the selected slide in a specified place with specified formatting (font, size, color, justified). I've been trying to reverse engineer anything applicable, but just end up breaking things. This set of code will allow me to make a rectangle (not a textbox which is preferred) size it and place it (just 1 not 2) with sample text.. For the life of me I cant figure out how to make it create a textbox on the selected slide or active window.. what am I doing wrong? Heres the code I found..
Sub AddTextBox()
Set myDocument = ActivePresentation.Slides(1)
With myDocument.Shapes _
.AddTextBox(msoShapeRectangle, 180, 175, 350, 140).TextFrame
.TextRange.Text = "Ctrl+A(Select all), Ctrl+V(Paste)"
.MarginTop = 10
End With
End Sub
To refer to the slide that's currently being displayed, you can use the Slide Property of the View object...
Dim mySlide As Slide
Set mySlide = ActiveWindow.View.Slide
For creating a textbox, here's the proper syntax as per the documentation here...
Syntax
expression. AddTextbox( Orientation, Left, Top, Width,
Height )
expression A variable that represents a Shapes object.
So, in your case, it would be something like this...
Dim myTextbox As Shape
Set myTextbox = mySlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 180, 175, 350, 140)
Change the text orientation as desired.
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
There is one thing I want to do in PowerPoint VBA.
I want to create two dots in the main window - dot A and dot B - by their given coordinates: for example, A (232, 464) and B (109, 567). I don't know how to do it in PowerPoint VBA. I know how to create a simple straight line. I use this macro code for that:
Sub CreateLine()
ActiveWindow.Selection.SlideRange.Shapes.AddLine(192#, 180#, 360#, 252#).Select
End Sub
But I still don't know how what code I would need to create just dots, not lines.
Then, I want to move those dots somehow.
Again, I know hot to move whole lines or other objects - for that I use this code:
Sub move()
ActiveWindow.Selection.ShapeRange.IncrementLeft 6#
End Sub
But I don't know how to move dots, especially if I want to move one dot one way (for example, move it up) and the other dot another way (for example, move it to the left).
Why do I want to do it?
Because later I am planning to keep those dots "connected" by straight lines, no matter which directions I move those dots.
If you know the answer, please share it with me here.
Thank you in advance.
in order to create a "dot" you use the "oval" shape, i.e. a small circle, where you can set line and fill colors to the same, i.e.
Sub DoDot()
'create a circular shape
ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeOval, 144.5, 150.88, 11.38, 11.38).Select
With ActiveWindow.Selection.ShapeRange
' color it
.Line.ForeColor.SchemeColor = ppAccent1
.Line.Visible = msoTrue
.Fill.ForeColor.SchemeColor = ppAccent1
.Fill.Visible = msoTrue
.Fill.Solid
' move it
.Top = 10
.Left = 10
End With
End Sub
I used the SchemeColor property here to color the shape, you can of course use an explicit RGB color as well.
Later on, if you want to connect dots with lines, you will need to either move the dots and
(re)create lines in between them, or you use dot-shaped line end types
Sub LineWithEndType()
ActiveWindow.Selection.SlideRange.Shapes.AddLine(195.62, 162.25, 439.38, 309.75).Select
With ActiveWindow.Selection.ShapeRange
.Line.Visible = msoTrue
.Fill.Transparency = 0#
.Line.BeginArrowheadStyle = msoArrowheadOval
.Line.EndArrowheadStyle = msoArrowheadOval
.Line.BeginArrowheadLength = msoArrowheadLong
.Line.BeginArrowheadWidth = msoArrowheadWide
.Line.EndArrowheadLength = msoArrowheadLong
.Line.EndArrowheadWidth = msoArrowheadWide
End With
End Sub
Hope that helps
Good luck MikeD