Here is my code for an interactive cart, but i have
error 13 run time
Sub Freeform124_Click()
Dim NomShape As String
NomShape = Application.Caller
For Each Shape In ActiveSheet.Shapes
form.Fill.ForeColor.RGB = RGB(0, 50, 0)
Next Shape
End Sub
The problem with your code is that you use for each Shape loop and then you write form.fill.forecolor.
Probably. Plus the application.caller parsed to string.
Here is a good way to change the color of all objects, if you make the macro clickable from an object.
Option Explicit
Sub Rechteck1_Klicken()
Dim oCaller As Object
Dim shShape As Shape
Set oCaller = ActiveSheet.Shapes(Application.Caller)
oCaller.Fill.ForeColor.RGB = RGB(100, 250, 250)
For Each shShape In ActiveSheet.Shapes
If shShape.Name <> oCaller.Name Then
shShape.Fill.ForeColor.RGB = RGB(110, 50, 0)
End If
Next shShape
End Sub
Related
I'm generating a largish presentation to run during a game showing players what stages they should have reached (the game isn't important). Each slide has a hollow circle/donut sweeping out an overall time while pictures appear showing the stage players should have reached. (The slides are being macro-generated as there are many variations, differing only slightly, including in timing details.)
When there are no sound effects, the macro works perfectly. When a sound effect is added to any .effect, the entire animation sequence is changed significantly and incorrectly. Timings that are assigned to start "With Previous" become "After Previous", durations are changed, the fade effect is lost. I've tried changing the sequence of the effect attribute assignments, adding a dummy shape and assigning the sound to that, no success.
Copying and running this simplified version demonstrates what happens - the same sub is used to generate two single-slide presentations on the desktop which should be the same other than sound effects, but are not.
Const CycleTime = 10
' CycleTime = Seconds for which the circular sweep should run;
' A shape appears for the first half then fades to be replaced by a second shape.
Dim fn$
Public Sub MakeTestPresentations()
fn$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "Test#" & Format(Now(), "hhmmss")
Call MakeASlide(UsingSound:=False)
Call MakeASlide(UsingSound:=True)
Exit Sub
End Sub
Sub MakeASlide(ByVal UsingSound As Boolean)
Dim sldThis As Slide, swp As Shape, shp1 As Shape, shp2 As Shape
' New blank presentation
Set pptSource = Presentations.Add
' Add a blank slide
Set sldThis = pptSource.Slides.Add(Index:=1, Layout:=ppLayoutBlank)
' Add a donut which will be the overall timer, set to sweep in CycleTime seconds
Set swp = sldThis.Shapes.AddShape(msoShapeDonut, 525, 83, 369, 369)
swp.Fill.ForeColor.RGB = RGB(0, 0, 128)
sldThis.TimeLine.MainSequence.AddEffect(Shape:=swp, effectId:=msoAnimEffectWheel, Trigger:=msoAnimTriggerWithPrevious).Timing.Duration = CycleTime
' Add a shape which should appear for the first half of the cycle, fading in & out
Set shp1 = sldThis.Shapes.AddShape(msoShapeCloud, 83, 83, 369, 369)
shp1.Fill.ForeColor.RGB = RGB(0, 255, 0)
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp1, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = 0
.Timing.Duration = CycleTime / 2
If UsingSound Then .EffectInformation.SoundEffect.Name = "Laser"
End With
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp1, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime / 2
.Exit = True
End With
' Add a shape which should appear for the second half of the cycle, fading in & out
Set shp2 = sldThis.Shapes.AddShape(msoShape16pointStar, 83, 83, 369, 369)
shp2.Fill.ForeColor.RGB = RGB(255, 0, 0)
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp2, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime / 2
.Timing.Duration = CycleTime / 2
If UsingSound Then .EffectInformation.SoundEffect.Name = "Drum Roll"
End With
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp2, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime
.Exit = True
End With
' Save the presentation
pptSource.SaveCopyAs fn$ & IIf(UsingSound, " (WITH Sound)", " (NO Sound)"), ppSaveAsDefault
pptSource.Close
Exit Sub
End Sub
I have a simple sub for adding background music:
Sub insert_rnd_back(Track As String)
Dim oSlide As Slide
Dim oShp As Shape
Dim oEffect As Effect
Set oSlide = ActivePresentation.Slides(1)
Set oShp = oSlide.Shapes.AddMediaObject2(Track, True, False, 10, 610)
With oShp.AnimationSettings.PlaySettings
.PlayOnEntry = msoTrue
.PauseAnimation = msoFalse
.StopAfterSlides = ActivePresentation.Slides.Count
.LoopUntilStopped = msoTrue
.HideWhileNotPlaying = msoTrue
.RewindMovie = msoTrue
End With
oShp.MediaFormat.Volume = 0.5
End Sub
And I am adding sounds to individual shapes with this:
Dim oShp As Shape
Dim oEffect As Effect
Set oShp = ActivePresentation.Slides(sld).Shapes.AddMediaObject2( _
aud & sityvebi(sld) & ".wav", True, False, 100, 610)
Set oEffect = ActivePresentation.Slides(sld).TimeLine.MainSequence.AddEffect( _
oShp, msoAnimEffectMediaPlay, , msoAnimTriggerAfterPrevious)
oShp.MediaFormat.Volume = 1
I'm programming a custom chart add-in for Word that should behave the same as add-ins I've already done for Excel and PowerPoint. The code is very similar in all three programs, but I'm getting a baffling error in Word that doesn't occur in the other 2 programs.
Excel (works just fine):
Sub AddTextboxToChart()
Dim oChart As Chart
Dim oChtShp As Shape
Dim oLegShp As Shape
sChtName = ActiveChart.Name
ChtShpName$ = Right(sChtName, Len(sChtName) - InStrRev(sChtName, " ", Len(ActiveSheet.Name) + 1))
Set oChtShp = ActiveSheet.Shapes(ChtShpName$)
Set oChart = oChtShp.Chart
Set oLegShp = oChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
oLegShp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End Sub
PowerPoint (also works fine):
Sub AddTextboxToChart()
Dim oChart As Chart
Dim oChtShp As Shape
Dim oLegShp As Shape
If ActiveWindow.Selection.ShapeRange(1).HasChart Then
Set oChtShp = ActiveWindow.Selection.ShapeRange(1)
Set oChart = oChtShp.Chart
Set oLegShp = oChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
oLegShp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End If
End Sub
Word (errors on "Set oLegShp" line):
Sub AddTextboxToChart()
Dim oChart As Chart
Dim oChtShp As Shape
Dim oLegShp As Shape
If ActiveWindow.Selection.ShapeRange(1).HasChart Then
Set oChtShp = ActiveWindow.Selection.ShapeRange(1)
Set oChart = oChtShp.Chart
Set oLegShp = oChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100) 'This line errors with Type Mismatch
oLegShp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End If
End Sub
Excel and PowerPoint behave as expected, but Word errors out with a Type Mismatch when it tries to set the shape reference to an added text box. Any ideas or workarounds?
If you try to run the code, create a sample chart in Word, then set it to be floating in front of the text. Otherwise, Word sees it as an Inline Shape, which is a whole other can of worms.
I'm running Version 2205 (Build 15225.20288 Click-to-Run) under Windows 10.
(Edit) A kludge to get around the bug:
oChart.Shapes.AddTextbox msoTextOrientationHorizontal, 100, 100, 100, 100
For x = 1 To oChart.Shapes.Count
If oChart.Shapes(x).Left = LegLeft And oChart.Shapes(x).Top = LegTop Then
oChart.Shapes(x).Fill.ForeColor.RGB = RGB(0,0,0)
End If
Next x
Is there any way to select the multiples shape from slide with the same shape name.
For e.g., I have 5 shapes with the name "Textbox 60". And I want run a macro which select all the shapes from a slide named "Textbox 60". Have used the below code.
ActiveWindow.View.Slide.Shapes.Range("Textbox 60").Select
Here's one approach:
Sub Tester()
SelectByName ActivePresentation.Slides(1), "Textbox1"
End Sub
Sub SelectByName(sld As Slide, nm As String)
Dim s As Shape, first As Boolean
first = True
For Each s In sld.Shapes
If s.Name = nm Then
s.Select first 'Argument determines whether to add to
first = False ' existing selection, or replace it
End If
Next s
End Sub
You should try following #TinMan's suggestion though - that is the "better" way to go.
Activating and Selecting Objects should be avoided whenever possible. You are better of working with the Shapes using a ShapeRange.
Sub Main()
Dim ShapeRange As ShapeRange
Set ShapeRange = FindShapes(ActiveWindow.View.Slide, "Textbox 60")
If Not ShapeRange Is Nothing Then
End If
End Sub
Function FindShapes(Slide As Slide, Pattern As String) As ShapeRange
Dim Results() As Long
ReDim Results(1 To Slide.Shapes.Count)
Dim n As Long
Dim Index As Long
For Index = 1 To Slide.Shapes.Count
With Slide.Shapes(Index)
.Name = "Textbox 60"
If .Name Like Pattern Then
n = n + 1
Results(n) = Index
End If
End With
Next
If n > 0 Then
ReDim Preserve Results(1 To n)
Set FindShapes = Slide.Shapes.Range(Results)
End If
End Function
Note: I rewrote the code to handle multiple shapes with the same name.
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 have to run many bar charts in excel 2016, each one showing the company performance over the seasons, for a certain country. On top of each bar I'd like to see the %Change in this format [Color10]0%"▲";[Red] -0%"▼". Reason why I added the data labels, and I used the function "value from cells" to show the %Change instead of the amount sold. Now everything is in place, and my percentages are nicely placed on top of the bars, but no way I can color them automatically (positive green and negative red). I tried formatting the labels directly from the format window placed under "numbers", but I discovered it doesn't work at all when the label content is derived using "value from cells".
So I started looking into VBA, but since I'm pretty ignorant about programming, I didn't succeed. I'm looking for a code that changes the data labels of my chart so that they maintain the font of the source (in the source my %Change values are already in the desired format ([Color10]0%"▲";[Red] -0%"▼"). Googling I found different solutions but none worked. I'll post the ones I that look better to me.
Sub legend_color()
Dim SRS As Series
With ActiveChart
For Each SRS In .SeriesCollection
SRS.ApplyDataLabels AutoText:=True, LegendKey:= _False,
ShowSeriesName:=False,
ShowCategoryName:=False,
ShowValue:=True, _ ShowPercentage:=False,
ShowBubbleSize:=False
SRS.DataLabels.Font.ColorIndex = SRS.Border.ColorIndex
Next SRS
End With
End Sub
This one was the only one that actually run, and colored my labels all white. With the following I run into errors.
Sub color_labels()
Dim chartIterator As Integer,
pointIterator As Integer, _seriesArray() As Variant
For chartIterator = 1 To ActiveSheet.ChartObjects.Count
seriesArray=ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _Chart.SeriesCollection(1).Values For pointIterator = 1 To UBound(seriesArray)
If seriesArray(pointIterator) >= 0 Then
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
Chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _RGB(146, 208, 80)
Else
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _Chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _RGB(255, 0, 0)
End If
Next pointIterator
Next chartIterator
End Sub
Sub ArrowColour()
Dim ncars As Integer
ncars = Range("A1").Value
With ActiveSheet.Shapes.Range(Array("Down Arrow 1")).Fill
If ncars > 0 Then
.ForeColor.RGB = RGB(0, 176, 80)
Else
.ForeColor.RGB = RGB(255, 0, 0)
End If
End With
End Sub
Option Explicit
Sub ApplyCustomLabels()
Dim rLabels As Range
Dim rCell As Range
Dim oSeries As Series
Dim Cnt As Integer
Set rLabels = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set oSeries = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
oSeries.HasDataLabels = True
Cnt = 1
For Each rCell In rLabels
With oSeries.Points(Cnt).DataLabel.Text = rCell.Value.Font.Color =rCell.Font.Color
End With
Cnt = Cnt + 1
Next rCell
End Sub
Thank you very much in advance for all of your help,
Tommaso
If you're just missing the colors then you can format each label using something like:
Sub Tester()
Dim s As Series, dl As DataLabels, d As DataLabel
Dim i As Long, rngLabels
Set s = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
Set dl = s.DataLabels
'Option 1: set label color based on label value
For i = 1 To dl.Count
With dl(i)
.Font.Color = IIf(Val(.Text) < 0, vbRed, vbGreen)
End With
Next i
'Option 2: set label color based on label source cell
' Note use of DisplayFormat to pick up custom
' formatting colors
Set rngLabels = Range("C7:C13")'<< source range for data labels
For i = 1 To dl.Count
dl(i).Font.Color = rngLabels(i).DisplayFormat.Font.Color
Next i
End Sub