I need to set the Transparency of Text in a shape via VBA, in fact I need to set the transparency for the whole shape but it's the text I'm stuck with.
I just can't seem to navigate the object model to find the Transparency Property
Function SetTransparency(Value As Single)
On Error GoTo AbortNameShape
If ActiveWindow.Selection.ShapeRange.Count = 0 Then
MsgBox "No Shapes Selected"
Exit Function
End If
With ActiveWindow.Selection.ShapeRange
.Fill.Transparency = Value
.Line.Transparency = Value
.TextFrame.TextRange. **HELP** .Transparency = Value
End With
AbortNameShape:
MsgBox Err.Description
End Function
Google has given me
.TextFrame.TextRange.Characters.Font.Fill.Transparency
From https://www.mrexcel.com/forum/excel-questions/510589-transparent-text-shapes-textbox-1-a.html
But that fails on the .Fill property of Font object not existing. I'm assuming MS have changed the object model in the 10 years that have passed since the answer was given, but I'm stuck for a current approach.
Thanks
Try this (for just the first member of the current selection)
With ActiveWindow.Selection.ShapeRange(1)
With .TextFrame2.TextRange.Font.Fill
.Transparency = 0.5
End With
End With
If you want to iterate through all the shapes in the current selection, you'll want to test each shape to see if .HasTextFrame and .TextFrame.HasText are true before trying to work with the text.
Related
I have a PowerPoint document where users can input text into several TextBoxes, over 6 slides in total.
On the last slide, I want to check if the user has filled in every TextBox in the presentation.
I tried using lots of code snippets on the internet and modifying them, however I am a complete VBA noob and, surprisingly, it did not work out. :')
I would greatly appreciate your help with this task.
It would be even better if it is possible to check whether the user has input AT LEAST 4 characters in each textbox. However I have no idea how to start programming this...
Here is my code, it does not show errors however nothing happens when clicking the CheckBox at the end.
Public Sub CheckTextBox()
Dim fTextBox As Object
For Each Slide In ActivePresentation.Slides
For Each fTextBox In ActivePresentation.Slides
If TypeName(fTextBox) = "TextBox" Then
If fTextBox.Text = "" Then
MsgBox "Please make sure to fill out all fields!"
End If
End If
Next
Next
End Sub
'When ticking this CheckBox, the MsgBox should show up
Private Sub CheckBox1_Click()
CheckTextBox
End Sub
Thank you guys so much for your help.
Your inner For-loop is wrong, you need to loop over all Shapes of the slide, instead, you start another loop over all slides.
Basically, all objects that you place on a slide are Shapes. If you use TypeName, you will get Shape. To distinguish the single shape-types, use the property type of the shape-object. A list of types can be found at https://learn.microsoft.com/de-de/office/vba/api/office.msoshapetype - a textbox has a type msoTextBox (17).
To get the text of a shape, use the property TextFrame.TextRange.Text of the shape.
Try the following code (it checks already for a length of at least 4 characters). It will stop at the first textbox that has less than 4 chars in it (else, you would get one MsgBox for every textbox) and select it.
Public Sub CheckTextBox()
Dim sh As Shape, slide As slide
For Each slide In ActivePresentation.Slides
For Each sh In slide.Shapes
Debug.Print TypeName(sh)
If sh.Type = msoTextBox Then
If Len(sh.TextFrame.TextRange.Text) < 4 Then
MsgBox "Please make sure to fill out all fields!"
slide.Select
sh.Select
Exit For
End If
End If
Next
Next
End Sub
UPDATE
The code above didn't take into account the shapes within groups. The following code loops over all shapes of all slides and calls the function checkShape that will check
a) If the shape is a textBox (msoTextBox, 17) - if yes, the length of the text is checked and if too short, that shape is returned.
b) If the shape is a group (msoGroup, 6), it calls (recursively) the function for all child shapes and returns the first child textbox found.
The main routine (CheckAllTextBoxes) checks if any textBox was found, and, if yes, will select it and issue the message.
Public Sub CheckAllTextBoxes()
Dim slide As slide, sh As Shape
For Each slide In ActivePresentation.Slides
For Each sh In slide.Shapes
Dim textBox As Shape
Set textBox = CheckShape(sh, 4)
If Not textBox Is Nothing Then
slide.Select
textBox.Select
MsgBox "Please make sure to fill out all fields!"
Exit Sub
End If
Next
Next
End Sub
Function CheckShape(sh As Shape, minLen As Integer) As Shape
' Check if shape is a Textbox and then text is not long enough
If sh.Type = msoTextBox Then
If Len(sh.TextFrame.TextRange.Text) < minLen Then
Set CheckShape = sh
Exit Function
End If
End If
' For a group, check all it's child shapes
If sh.Type = msoGroup Then
Dim child As Shape
For Each child In sh.GroupItems
Dim textBox As Shape
Set textBox = CheckShape(child, minLen)
If Not textBox Is Nothing Then
' Found a Textbox within the group, return it
Set CheckShape = textBox
Exit Function
End If
Next child
End If
End Function
For those looking for c# code to list all text boxes in a presentation:
using Microsoft.Office.Interop.PowerPoint;
using MsoShapeType = Microsoft.Office.Core.MsoShapeType;
public static IEnumerable<Shape> AllTextBoxes (Presentation presentation) =>
from slide in presentation.Slides.Cast<Slide>()
from shape in slide.Shapes.Cast<Shape>()
from textBox in AllTextBoxes(shape)
select textBox;
public static IEnumerable<Shape> AllTextBoxes (Shape sh)
{
IEnumerable<Shape> _() { if (sh.Type == MsoShapeType.msoTextBox) yield return sh; }
return sh.Type == MsoShapeType.msoGroup ? sh.GroupItems.Cast<Shape>().SelectMany(AllTextBoxes) : _();
}
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.
I'm just poking around in VBA with PowerPoint and know that what I want to do can be done. I just don't know the write calls/sytanx to use!
I want a macro that will run through all the slides in a presentation and move the video object to specific spot on the slide. The spot will be the same on all slides.
It would be very helpful if someone could show me how to do this! Or at least point me in the right direction. Thanks!
Here's what I found for doing something on every slide
Sub EveryTextBoxOnSlide()
' Performs some operation on every shape that contains text on every slide
' (doesn't affect charts, tables, etc)
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
' If font size is mixed, don't touch the font size
If .TextFrame.TextRange.Font.Size > 0 Then
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size + 2
End If
End If
End If
End With
Next ' shape
Next ' slide
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
And this is something I found to move the object to desired location (here's where I don't know what to call the video object)
With ActiveWindow.Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End Sub
Sub ll()
End Sub
So basically, I want to run the last piece as a function of the first one instead of shapes with text. Does that make sense?
I've done some programming in the past, mainly with actionscript and Flash. I could probably write out some basic functions, just not sure how to run it in VBA without learning a whole new language. Which I don't want to do, since I'm an instructional designer and don't have the free time to learn it! :)
Here's a little function that'll return True if the shape you pass to it is a video, and a bit of example code to test it with:
Function IsVideo(oSh As Shape) As Boolean
If oSh.Type = msoMedia Then
If oSh.MediaType = ppMediaTypeMovie Then
IsVideo = True
Exit Function
End If
End If
' Things get a little trickier if the movie is in a placeholder
' Is it a placeholder? and is it a media object?
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoMedia Then
' it's a media object, but we don't know if it's
' a movie or sound or what, so we duplicate it
' then look at the duplicate (which is now a copy
' of the placeholder content but is not a placeholder itself)
With oSh.Duplicate
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
IsVideo = True
End If
End If
' and delete the duplicate
.Delete
End With
End If
End If
End Function
Sub thing()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If IsVideo(oSh) Then
oSh.Left = 0
End If
Next
Next
End Sub
Now you're getting somewhere!
I don't know what kind of shape holds your video, so this modification should help you identify it.
Sub EveryTextBoxOnSlide()
Dim oSh As Shape
Dim oSl As Slide
On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
.Select
End With
Next
Next
NormalExit:
Exit Sub
ErrorHandler:
Resume Next
End Sub
While there is no need whatsoever to use the .Select in your final code, this is only here to help you identify which shape actually holds the video. Put a breakpoint (F9) on that line and run your code (F5), then debug through it with F8 to execute one line at a time and run through your loop looking at each shape until you see that your video has been selected.
Once your video has been selected look at the various properties (using the Immediate Window of the IDE) of oSh until you find the uniqueness that identifies this is your video. (There may be some property about the content type of the shape, or a link on where to find the contents that contains the text string ".avi", ".mpg", ".flv", etc - there will be some sort of identifier you can find.)
Once you've identified what makes the shape the holder of a video, replace
.Select
with
If {my video containing shape criteria is true} Then
With .Selection.ShapeRange
.Left = 640 'change the number for desired x position
.Top = 75 'change the number for desired y position
End With
End If
Changing the values (as commented) to whatever it is that you need.
Important Note: It is very good that your sample code has some error handling built in, but all this error handler is doing is sweeping any errors under the rug. This particular handler is the very long form version of On Error Resume Next which does have its uses, but in very, very limited situations.
As you get your code working, you'll actually want to put something useful in the ErrorHandler: section, but that's the topic for a whole new question.
Ok, here is how I modified the code supplied above to do this in my case:
Sub EveryTextBoxOnSlide() ' Performs some operation on every shape that contains text on every slide ' (doesn't affect charts, tables, etc) Dim oSh As Shape Dim oSl As Slide On Error GoTo ErrorHandler
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
With oSh
If .Type = msoMedia Then
If .MediaType = ppMediaTypeMovie Then
.PictureFormat.Crop.PictureHeight = 236
.PictureFormat.Crop.PictureWidth = 314.2115
.PictureFormat.Crop.PictureOffsetX = 8.737323
.PictureFormat.Crop.PictureOffsetY = 0
.PictureFormat.Crop.ShapeHeight = 236.3478
.PictureFormat.Crop.ShapeWidth = 163
.PictureFormat.Crop.ShapeLeft = 796.6956
.PictureFormat.Crop.ShapeTop = 0
End If
End If
End With
Next ' shape Next ' slide
NormalExit: Exit Sub
ErrorHandler: Resume Next
End Sub
I am searching for a way to perform the following operation on two shapes that are selected in powerpoint.
Take the shape in the foreground (i.e. the shape that is more in the front) of the two shapes and left and bottom align it with the one that is in the background.
2. Delete the shape in the background.
What I have got so far is the operation for the bottom and left align which looks as follows:
Sub LeftandBottom_Align()
ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, False
ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, False
End Sub
How do i get the delete-part done?
A little bit of basic explanation would be great
You can delete the rearmost shape like so:
Dim oBackShape As Shape
With ActiveWindow.Selection
' Get a reference to the rearmost of the two selected shapes
' so you can use it later to delete the shape
If .ShapeRange(1).ZOrderPosition > .ShapeRange(2).ZOrderPosition Then
Set oBackShape = .ShapeRange(2)
Else
Set oBackShape = .ShapeRange(1)
End If
' Align the shapes
' .Align may not always work the way you'd expect it to
' so if not, ask
.ShapeRange.Align msoAlignLefts, False
.ShapeRange.Align msoAlignBottoms, False
End With
' Delete the rearmost shape
oBackShape.Delete
You can use Shapes ZOrderPosition Property to determine which shape is in the background
Sub LeftandBottom_Align()
ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, False
ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, False
Dim i As Integer
i = 2 'Assuming two shapes
While i >= 1
With ActiveWindow.Selection.ShapeRange(i)
If (.ZOrderPosition = 1) Then
.Delete
Exit Sub
End If
i = i - 1
End With
Wend
End Sub
I would like to grey out my checkboxes in Excel VBA. When using Checkbox.Enabled = False, the checkbox is not editable, but it is also not grey. How do I get the greyed out effect?
Using form controls with Excel 2010. Inserted via developer tab directly into excel worksheet. Not used in a VBA userform.
Thanks!
Whenever anyone says "it is impossible", it hits my stubborn streak. So may I present to you: "The Impossible".
"Visible" and enabled checkbox:
"Disabled" checkbox (you can tweak the degree of visibility by changing values in the code for both color and transparency of the cover shape):
Basic idea: you place a semi transparent shape over the checkbox, and assign a dummy macro to it. Now you can't change the value of the checkbox. The "toggle" button is there to change the state - either place the shapes, or remove them. It uses a global variable to track the current state.
Finally - note that you can't use For Each when you delete (or add) shapes as you should not modify the collection you are iterating over. I circumvented that with a simple "count shapes, then iterate backwards by numerical index".
Is it a hack? You bet! Does it do what you asked? Yes!
Dim checkBoxesVisible As Boolean
Option Explicit
Sub toggleIt()
' macro assigned to "Toggle visibility" button
checkBoxesVisible = Not checkBoxesVisible
toggleCheckboxes checkBoxesVisible
End Sub
Sub grayOut(cb)
' put a "cover" shape over a checkbox
' change the color and transparency to adjust the appearance
Dim cover As Shape
Set cover = ActiveSheet.Shapes.AddShape(msoShapeRectangle, cb.Left, cb.Top, cb.Width, cb.Height)
With cover
.Line.Visible = msoFalse
With .Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.Transparency = 0.4
.Solid
End With
End With
cover.Name = "cover"
cover.OnAction = "doNothing"
End Sub
Sub doNothing()
' dummy macro to assign to cover shapes
End Sub
Sub unGray(cb)
' find the cover shape for the checkbox passed as the argument
' and delete it
' "correct shape" has the name "cover" and is properly aligned with top left
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.Name = "cover" And sh.Left = cb.Left And sh.Top = cb.Top Then
sh.Delete
Exit For
End If
Next sh
End Sub
Sub toggleCheckboxes(onOff)
Dim s As Shape
Dim n As Integer, ii As Integer
n = ActiveSheet.Shapes.Count
' loop backwards over shapes: if you do a "For Each" you get in trouble
' when you delete things!
For ii = n To 1 Step -1
Set s = ActiveSheet.Shapes(ii)
If s.Type = msoFormControl Then
If s.FormControlType = xlCheckBox Then
If onOff Then
unGray s
Else
grayOut s
End If
End If
End If
Next ii
End Sub
A slight hack - but the following does work. I created a simple userform with two controls - a regular checkbox (CheckBox1), and a button I called "DisableButton" with the following code:
Private Sub DisableButton_Click()
CheckBox1.Enabled = Not (CheckBox1.Enabled)
If CheckBox1.Enabled Then
CheckBox1.ForeColor = RGB(0, 0, 0)
Else
CheckBox1.ForeColor = RGB(128, 128, 128)
End If
End Sub
When I clicked the button, the checkbox was grayed out and unavailable. Clicking it again "brought it back to life". I think this is the effect you were looking for. If it's not - that's what comments are for.
Here is what it looks like:
I am afraid it is impossible what you are trying to do within a worksheet. You can refer to the Floris' answer if you are using an UserForm.
For more details on the properties of (Form/worksheet) check boxes see MSDN
Maybe this is what you want.
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
CheckBox2.Value = False
CheckBox2.Enabled = False
CheckBox2.ForeColor = rgbBlue
Else
CheckBox2.Visible = True
CheckBox2.ForeColor = rgbAntiqueWhite
CheckBox2.Enabled = True
End If
Code tels that when checkbox1 is checked, checkbox2 is disabled; unchecked and the forecollor changes. the colors can be what you want.
Did this with the checkboxes directly in the excel worksheet.
Based on Floris' idea.
The code assumes all the controls are on ActiveSheet and they are called CheckBox1 and CheckBox2, if not, change it accordingly.
You can call this when you click on CheckBox1 or you can call it from another sub, with an optional ticked status (True/False) to check or uncheck CheckBox1.
Draw an object on top of CheckBox2 and name it "mask" (you can name it anything else but then you have to change the code accordingly)
Give mask the same fill color as your background color and opacity of around 50%.
Public Sub CheckBox1_Click(Optional ticked As Variant)
Application.ScreenUpdating = False
ActiveSheet.Unprotect
If Not IsMissing(ticked) Then
If ticked = True Then ActiveSheet.Shapes("CheckBox1").OLEFormat.Object.Value = 1 Else ActiveSheet.Shapes("CheckBox1").OLEFormat.Object.Value = -4146
End If
If ActiveSheet.Shapes("CheckBox1").OLEFormat.Object.Value > 0 Then
ActiveSheet.Shapes("mask").OLEFormat.Object.ShapeRange.ZOrder msoSendToBack
Else
ActiveSheet.Shapes("mask").OLEFormat.Object.ShapeRange.ZOrder msoBringToFront
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub
Now each time you tick CheckBox1, mask comes to front to hide CheckBox2 and when you untick it, mask goes to back to unhide it. Since it is opaque, it gives you the greyed out effect and you don't even have to worry about enable/disable either.
Worksheet should be protected so that user can't accidentally move or edit mask, but should be unprotected for SendToBack/BringToFront to work, so the code does that. Please check the protection settings at the Application.Protect part.