I wrote this sub to toggle a shape's Lock Aspect Ratio. It turns locks it but it doesn't unlock it
Sub ToggleAspectRatio()
With ActiveWindow.Selection.ShapeRange
MsgBox .LockAspectRatio
'On Error GoTo err_handler:
'Unlock
If .LockAspectRatio = msoCTrue Then .LockAspectRatio = msoFalse
'Lock
If .LockAspectRatio = msoFalse Then .LockAspectRatio = msoCTrue
End With
On Error GoTo 0
Exit Sub
'Error Handler - No Object is Currently Selected
err_handler:
MsgBox "No object is selected"
Exit Sub
End Sub
Please help me. Thanks in advance.
Your first If statement sets LockAspectRatio to false, your second detects the false and sets it back to true. Instead, use an Else statement:
If .LockAspectRatio = msoTrue Then
.LockAspectRatio = msoFalse
Else
.LockAspectRatio = msoTrue
End If
I found the solution. A few too many errors on my behalf.
Here's the working code:
Sub ToggleAspectRatio()
'PURPOSE: Toggle Lock Aspect Ratio Property on/off
Dim ShapeName As String
On Error GoTo err_handler
With ActiveWindow.Selection.ShapeRange
If .LockAspectRatio = True Then
.LockAspectRatio = False
Else
.LockAspectRatio = True
End If
End With
Exit Sub
err_handler:
MsgBox "No object is selected"
Exit Sub
End Sub
Thanks #johnk
Related
I have the below code that colors all the buttons (there are 10) grey to clear any previously colored button, and then colors the button selected blue. Basically acting as an indicator of what button is currently selected. I noticed that the code now takes a moment to run with this cosmetic addition and I was wondering if there is any way to re-write this to run faster?
Thank you for your help and please let me know if I can provide any more detail
'
' all_days Macro
'change all buttons to grey first
ActiveSheet.Shapes.Range(Array("Rectangle: Rounded Corners 17", _
"Rectangle: Rounded Corners 12", "Rectangle: Rounded Corners 11")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.5
.Transparency = 0
.Solid
End With
'change selected button to blue
ActiveSheet.Shapes.Range(Array("Rectangle: Rounded Corners 12")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Solid
End With
ActiveSheet.Range("$A$1:$X$740").AutoFilter Field:=12
ActiveSheet.Range("$A$1:$X$100000").AutoFilter Field:=17
End Sub```
Highlight Clicked Shape
Sub HighlightClickedShape()
Dim ShapeNames() As Variant
ShapeNames = Array("Rectangle: Rounded Corners 17", _
"Rectangle: Rounded Corners 12", "Rectangle: Rounded Corners 11")
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim shprg As ShapeRange: Set shprg = ws.shapes.Range(ShapeNames)
ResetShapeRange shprg
Dim shp As Shape
On Error Resume Next
Set shp = shprg(Application.Caller)
On Error GoTo 0
If shp Is Nothing Then
MsgBox "This only works when clicking on one of the following shapes:" _
& vbLf & vbLf & Join(ShapeNames, vbLf), vbCritical
Exit Sub
End If
HighlightShape shp
End Sub
Sub ResetShapeRange(ByVal shprg As ShapeRange)
With shprg.Fill.ForeColor
.ObjectThemeColor = msoThemeColorBackground1
.Brightness = -0.5
End With
End Sub
Sub HighlightShape(ByVal shp As Shape)
With shp.Fill.ForeColor
.ObjectThemeColor = msoThemeColorAccent1
.Brightness = -0.25
End With
End Sub
I suspect that the Select is slowing down the process, and it is not necessary at all. Usually the code that the macro recorder is creating needs to be streamlined, especially it is always never needed to select something.
I created a sheet with nearly 100 shapes and the following code runs rather instantly (and my PC is 6 years old...). It loops over all shapes of a worksheet, checks if the shape should be colored by testing the name of it. This check is outsourced to a private function to make the code more readable - simply adapt the if-statement there. And if you want to color all shapes of the sheets, you can let the function return True in any case, no need to check the names.
In my version, the routine uses Application.Caller to find the shape that was clicked to paint it with blue - therefore you can use the same routine for all shapes.
Sub shapes()
Dim ws As Worksheet, sh As Shape
Set ws = ActiveSheet
For Each sh In ws.shapes
If isButtonShape(sh) Then
sh.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground2
End If
Next
On Error Resume Next
Set sh = Nothing
Set sh = ws.shapes(Application.Caller)
On Error GoTo 0
If Not sh Is Nothing Then
If isButtonShape(sh) Then
sh.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
sh.Fill.ForeColor.TintAndShade = 0
End If
End If
End Sub
Private Function isButtonShape(sh As Shape) As Boolean
isButtonShape = (sh.Name = "Rectangle: Rounded Corners 17" _
Or sh.Name = "Rectangle: Rounded Corners 12" _
Or sh.Name = "Rectangle: Rounded Corners 11")
End Function
This is the code that I ended up using
'change all buttons to grey first
Dim shapenames() As Variant
Dim ws As Worksheet: Set ws = ActiveSheet
shapenames = Array("Rectangle: Rounded Corners 17", "Rectangle: Rounded Corners 12", "Rectangle: Rounded Corners 11")
Dim shprg As ShapeRange: Set shprg = ActiveSheet.shapes.Range(shapenames)
With shprg.Fill.ForeColor
.ObjectThemeColor = msoThemeColorBackground1
.Brightness = -0.5
End With
'change selected button to blue
Dim shapename() As Variant
shapename = Array("Rectangle: Rounded Corners 12")
Set shprg = ActiveSheet.shapes.Range(shapename)
With shprg.Fill.ForeColor
.ObjectThemeColor = msoThemeColorAccent1
End With
working in PowerPoint, I need to call a sub from a different slide. For example, I'm creating a macro that is located in one slide, and refers to a sub in another slide, for example:
**Slide 3:**
Sub Login()
If Slide3.LoginBox.Text = Slide1.CreatePasswordLogin.Text Then
ActivePresentation.SlideShowWindow.View.Next
Slide3.LoginBox.Text = ""
Call LoginShapeLoad (the one from slide 4 for example)
Else
MsgBox "Incorrect Password!", vbExclamation, "Login Prompt"
Slide3.LoginBox.Text = ""
End If
End Sub
**Slide 4:**
Sub LoginShapeLoad()
If Shapes("Shape1").Visible Then
Else
Shapes("Shape1").ZOrder msoBringToFront
Shapes("Shape1").Visible = msoTrue
End If
End Sub
Add a module to your VBA project and put this code there. You can then call it from anywhere else.
Public Sub LoginShapeLoad()
With ActivePresentation.Shapes("Shape1")
If Not .Visible Then
.ZOrder msoBringToFront
.Visible = msoTrue
End If
End With
End Sub
Or to make it more generically useful:
Public Sub LoginShapeLoad(oSh as Shape)
With oSh
If Not .Visible Then
.ZOrder msoBringToFront
.Visible = msoTrue
End If
End With
End Sub
And invoke it with something like this:
Sub MakeAnyShapeVisible()
Dim oSh as Shape
' Change 42 to the slide number, SomeName to the shape name
' you want to make visible:
Set oSh = ActivePresentation.Slides(42).Shapes("SomeName")
Call LogInShapeLoad(oSh)
End Sub
For internal communication purposes in a group of people I have created a macro adding comment fields to a slide - not those of PPT itself.
Dim shp As Shape
Dim sld As Slide
'Comment field
On Error GoTo ErrMsg
If ActiveWindow.Selection.SlideRange.Count <> 1 Then
MsgBox "This function cannot be used for several slides at the same time"
Exit Sub
Else
Set sld = Application.ActiveWindow.View.Slide
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=0, Top:=104.88182, Width:=198.42507, Height:=28.913368)
shp.Fill.Visible = msoTrue
shp.Fill.Transparency = 0
shp.Fill.ForeColor.RGB = RGB(211, 61, 95)
shp.Line.Visible = msoTrue
shp.Line.ForeColor.RGB = RGB(255, 255, 255)
shp.Line.Weight = 0.75
shp.Tags.Add "COMMENT", "YES"
shp.Select
shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
shp.TextFrame.TextRange.Characters.Text = "Comment: "
shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
shp.TextFrame.VerticalAnchor = msoAnchorTop
shp.TextFrame.TextRange.Font.Size = 12
shp.TextFrame.TextRange.Font.Name = "Arial"
shp.TextFrame.TextRange.Font.Bold = msoTrue
shp.TextFrame.TextRange.Font.Italic = msoFalse
shp.TextFrame.TextRange.Font.Underline = msoFalse
shp.TextFrame.Orientation = msoTextOrientationHorizontal
shp.TextFrame.MarginBottom = 7.0866097
shp.TextFrame.MarginLeft = 7.0866097
shp.TextFrame.MarginRight = 7.0866097
shp.TextFrame.MarginTop = 7.0866097
shp.TextFrame.WordWrap = msoTrue
shp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
shp.TextFrame.TextRange.Select
End If
Exit Sub
ErrMsg:
MsgBox "Please select a slide"
End Sub
Works well.
I have tagged them, because I want it to be easy to delete all of them at once, e.g., in case you find comments 5 minutes before you have to present. Here's my way to delete them:
Sub CommDel()
Dim sld As Slide
Dim L As Long
If MsgBox("Do you want to delete ALL comments from the entire presentation?", vbYesNo) <> vbYes Then Exit Sub
On Error Resume Next
For Each sld In ActivePresentation.Slides
For L = sld.Shapes.Count To 1 Step -1
If sld.Shapes(L).Tags("COMMENT") = "YES" Then sld.Shapes(L).Delete
Next L
Next sld
End Sub
Works fine, too.
Third step I would like to do, is creating a third macro, called "find next comment". On every click it jumps to the next shape tagged with the tag "COMMENT", no matter if that shape is on the same slide or the next or somewhere else in the presentation. Just the next one, where ever it is. And now I'm completely lost. I am able to do something to all tagged shapes on one slide or inthe entire presentation - as you can see in the function to delete. But what I'm looking for is not selecting all shapes at the same time. In another try I was able to find the first one - but after clicking the macro again nothing seemed to happen, because the macro started searching at the same point and selected the same shape again and again, never jumping to the next one, except I deleted the first one.
Would be great to read your ideas. Thank you in advance. But be careful, I'm far from being a good programmer. ;-)
This starts at the current slide and works toward the end, dropping out of the Sub as soon as the first comment is found:
Sub FindNextComment()
Dim oSlide As Slide
Dim oShape As Shape
Set oSlide = ActiveWindow.View.Slide
For Each oShape In oSlide.Shapes
If oShape.Tags.Count > 0 Then
For y = 1 To oShape.Tags.Count
If oShape.Tags.Name(y) = "COMMENT" Then
oShape.Select
Exit Sub
End If
Next y
End If
Next oShape
For x = oSlide.SlideIndex + 1 To ActivePresentation.Slides.Count
For Each oShape In ActivePresentation.Slides(x).Shapes
If oShape.Tags.Count > 0 Then
For y = 1 To oShape.Tags.Count
If oShape.Tags.Name(y) = "COMMENT" Then
ActivePresentation.Slides(x).Select
oShape.Select
Exit Sub
End If
Next y
End If
Next oShape
Next x
End Sub
Bonus VBA Tip: You can make your code run a little faster by using With statements:
With shp.TextFrame
.MarginBottom = 7.0866097
.MarginLeft = 7.0866097
.MarginRight = 7.0866097
.MarginTop = 7.0866097
.WordWrap = msoTrue
.AutoSize = ppAutoSizeShapeToFitText
.Orientation = msoTextOrientationHorizontal
.VerticalAnchor = msoAnchorTop
With .TextRange
.Characters.Text = "Comment: "
.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Size = 12
.Name = "Arial"
.Bold = msoTrue
.Italic = msoFalse
.Underline = msoFalse
End With
End With
End With
I hope you are doing well.
I am a little stuck on a macro scripting, I would like to perform the following
Once the macro is launch ; create a form rectangle with attributes (see below)
If a rectangle already exist within the active slide the delete it.
Here is the little macro code written to insert the shape
Sub TBU()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 902, 5, 47, 27)
With oSh
With .TextFrame.TextRange
.Text = "[TBU]"
With .Font
.name = "Arial"
.Size = 12
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color = RGB(255, 0, 0)
End With
End With
With oSh
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 0)
.Fill.Solid
End With
End With
End Sub
I tried to delete the shape within the active slide only if a rectangle with the same attributes already existed but got stuck on that.
Does anyone has an idea?
Kind regards,
Naxos
I think the best way to find any shapes that you want to delete is to iterate over all the shapes in the current slide, and call a function that checks if the shape given matches your criteria.
It would look something like the code below. Basically, any one condition not matching is sufficient to say that the shape shouldn't be deleted. Therefore the function starts off by assuming that the shape should be deleted until it finds any condition that indicates otherwise, at which point it changes the return value to false and ceases checking for the given shape.
Dim i as Long
Dim sh as Shape
For i = ActiveWindow.View.Slide.Shapes.Count to 1 Step -1
Set sh = ActiveWindow.View.Slide.Shapes(I)
If ShouldBeDeleted(sh) Then
sh.Delete
End If
Next
'...
Function ShouldBeDeleted(sh as Shape) as Boolean
ShouldBeDeleted = True
'Repeat this IF structure for each criteria.
If sh.Fill.Visible <> msoTrue Then
ShouldBeDeleted = False
Exit Function
End If
If Not sh.HasTextFrame Then
ShouldBeDeleted = False
Exit Function
End If
'... keep repeating these if structures.
End Function
I am working in VBA on Word 2010.
I have some code to add borders to an inlineshape which is working ok, but I need to be able to remove the border and that doesn't seem to be working. I've searched through this site and can't find anything close apart from this:
Mimic word borders and shading option "apply to:" (text) with vba on an inline shape
Code is a follows:
Sub TestAddBorders()
Dim rngShape As InlineShape
For Each rngShape In ActiveDocument.InlineShapes
With rngShape.Range.Borders
.OutsideLineStyle = wdLineStyleSingle
.OutsideColorIndex = wdPink
.OutsideLineWidth = wdLineWidth300pt
End With
Next rngShape
End Sub
Sub TestRemoveBorders()
Dim rngShape As InlineShape
For Each rngShape In ActiveDocument.InlineShapes
With rngShape.Range.Borders
.OutsideLineStyle = wdLineStyleNone
End With
Next rngShape
End Sub
I am always left with a picture (inlineshape) that has a greyish border around it. Using "Picture Border > No Outline" on the Picture Tools > Format Tab removes it, but I can' find any way to do it in VBA. The wdLineStyleNone just doesn't seem to work and I can't see an option for colour = "none", or linewidth = "none"
Thank you.
From MSDN:
To remove all the borders from an object, set the Enable property to False.
http://msdn.microsoft.com/en-us/library/office/ff196058.aspx
This will remove the borders as you applied them:
Sub TestRemoveBorders()
Dim rngShape As InlineShape
For Each rngShape In ActiveDocument.InlineShapes
With rngShape.Range.Borders
.Enable = False
End With
Next rngShape
End Sub
The above method removes borders but not lines. To remove lines, try this:
With rngShape.Line
.Visible = msoFalse
End With
David's answer is correct, but I wanted to add to it for anyone who stumbles upon this later.
I prefer not to use the Borders method that I see most other people list to add a border to an InlineShape, and thanks to David's answer here I learned that you can just use the Line member like you can with normal Shapes!
I'm aware that this might not exactly answer the question for those of you who are not also setting the border yourself, but in my personal case it was helpful. With that in mind, here are the revised versions of methods to Add and Remove the borders from shapes.
Option Explicit
Sub PicturesAll_Borders_Show()
'for pictures which are "In Line with Text"
Dim inShp As InlineShape
For Each inShp In ActiveDocument.InlineShapes
If inShp.Type = wdInlineShapePicture Then
With inShp.Line
.Visible = True
.Style = msoLineSingle
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
End With
End If
Next inShp
'for pictures which are "With Text Wrapping"
Dim shp As Shape
For Each shp In ActiveDocument.Shapes
If shp.Type = msoPicture Then
With shp.Line
.Visible = True
.Style = msoLineSingle
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
End With
End If
Next shp
End Sub
Sub PicturesAll_Borders_Hide()
'for pictures which are "In Line with Text"
Dim inShp As InlineShape
For Each inShp In ActiveDocument.InlineShapes
If inShp.Type = wdInlineShapePicture Then inShp.Line.Visible = False
Next inShp
'for pictures which are "With Text Wrapping"
Dim shp As Shape
For Each shp In ActiveDocument.Shapes
If shp.Type = msoPicture Then shp.Line.Visible = False
Next shp
End Sub