Was trying to script to apply fill colour and shadows together with the help of below scripts
Sub Blue1() 'blue 1
Dim sldFirst As Slide
Set sldFirst = ActivePresentation.Slides(1)
For Each Shape In ActiveWindow.Selection.ShapeRange
Shape.Fill.ForeColor.RGB = RGB(69, 159, 237)
Shape.TextFrame.TextRange.ParagraphFormat.Alignment = msoAlignCenter
Shape.Line.Visible = False
With Shape.Shadow
.Size = 100
.ForeColor.RGB = RGB(0, 112, 192)
.Transparency = 0.8
.Blur = 15
.OffsetX = 0
.OffsetY = 3
End With
Next
End Sub
But when i run the code on first click only it applies the fill colour for shadow i have to click run button second time. can you please help me to sort this out.
Thanks in advance
I think you found a bug. The color should get applied the first time around. However, running the command a second time does the job:
Sub Blue1() 'blue 1
Dim sldFirst As Slide
Set sldFirst = ActivePresentation.Slides(1)
For Each Shape In ActiveWindow.Selection.ShapeRange
With Shape
.Fill.ForeColor.RGB = RGB(69, 159, 237)
.TextFrame.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.Line.Visible = False
With .Shadow
.Size = 100
.Transparency = 0.8
.Blur = 15
.OffsetX = 0
.OffsetY = 3
.ForeColor.RGB = RGB(0, 112, 192)
.ForeColor.RGB = RGB(0, 112, 192)
End With
End With
Next
End Sub
Related
I am seeking a way to insert a watermark into Word documents. Here is the code I get by recording Macros,
Sub add_watermark()
'
' Macro2 Macro
'
'
ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.AddTextEffect( _
PowerPlusWaterMarkObject354239640, "PAID", "arial", 1, False, False, 0, 0 _
).Select
Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640"
Selection.ShapeRange.TextEffect.NormalizedHeight = False
Selection.ShapeRange.Line.Visible = False
Selection.ShapeRange.Fill.Visible = True
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 192, 192)
Selection.ShapeRange.Fill.Transparency = 0
Selection.ShapeRange.Rotation = 315
Selection.ShapeRange.LockAspectRatio = True
Selection.ShapeRange.Height = CentimetersToPoints(9.31)
Selection.ShapeRange.Width = CentimetersToPoints(13.96)
Selection.ShapeRange.WrapFormat.AllowOverlap = True
Selection.ShapeRange.WrapFormat.Side = wdWrapNone
Selection.ShapeRange.WrapFormat.Type = 3
Selection.ShapeRange.RelativeHorizontalPosition = _
wdRelativeVerticalPositionMargin
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionMargin
Selection.ShapeRange.Left = wdShapeCenter
Selection.ShapeRange.Top = wdShapeCenter
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
But I have an "out of range" error after running the Macro in another document. When I debug it, this line
"Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640" is highlighted.
Does anyone know how to tackle it?
Thanks,
Try something based on:
Sub AddPaidWatermark()
Application.ScreenUpdating = False
Dim sWdth As Single, Shp As Shape
With ActiveDocument.Sections(1)
With .PageSetup
sWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With .Headers(wdHeaderFooterPrimary)
If .Range.Characters.First.Information(wdWithInTable) = True Then
With .Range.Tables(1)
.Rows.Add .Rows(1)
.Split .Rows(2)
End With
.Range.Tables(1).Delete
.Range.Paragraphs(1).Range.Font.Hidden = True
End If
Set Shp = .Shapes.AddTextEffect(msoTextEffect1, "PAID", "Arial", 1, False, False, 0, 0)
End With
With Shp
.WrapFormat.Type = wdWrapBehind
.ZOrder msoBringToFront
.Height = sWdth / 2 ^ 0.5
.Width = .Height
.Rotation = 315
.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeCenter
.Top = wdShapeCenter
With .Fill
.Visible = True
.Solid
.ForeColor.RGB = RGB(192, 192, 192)
End With
End With
End With
Application.ScreenUpdating = True
End Sub
I have the following function, which I intended to create a shape:
Public Function LinkToAddInfo(ShapeName As String, BoxName As String, DisplayNumber As Long, AddName As String, TrueNumber As Long) As Shape
Dim ShapeName As Shape
Set ShapeName = .Shapes.AddShape(msoShapeRoundedRectangle, 640, 470, 71, 27)
With ShapeName
.Fill.ForeColor.RGB = RGB(191, 191, 191)
.Fill.Transparency = 0
.Name = BoxName
With .Line
.Weight = 0
.ForeColor.RGB = RGB(191, 191, 191)
.Transparency = 0
End With ' Outline
With .TextFrame.TextRange
.Text = "Add. Info " & DisplayNumber & vbNewLine & AddName
With .Font
.Name = "Arial"
.Size = 8
.Bold = msoTrue
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.RGB = RGB(255, 255, 255)
End With ' Font
End With ' TextFrame
End With ' Square itself
End Function
I tried to call it from within a module using:
LinkToAddInfo("tiny1", "Yedinfo1", DisplayNumber, AddName, AddNumber)
But it throws an error (the code is shown in red within the editor).
When I have all the code within the module itself, it works fine. I'm just struggling to transcribe it into an external function (which I want to do so that I don't have to repeat this code again and again).
How can I achieve this?
You have several problems with this.
You don't need a Function for this, since you aren't returning data to the program. Instead, use a Sub.
The first argument is a string, but then you try to use the same variable name in a declaration as a shape. But you don't use the string argument for anything, so it can be deleted. You also don't use TrueNumber, so that can be taken out.
To access a slide master, you need to use Designs with a numeric argument, not SlideMaster.
The following should do what you want:
Public Sub LinkToAddInfo(BoxName As String, DisplayNumber As Long, AddName As String)
Dim oShape As Shape
Set oShape = ActivePresentation.Designs(1).SlideMaster.Shapes.AddShape(msoShapeRoundedRectangle, 640, 470, 71, 27)
With oShape
.Fill.ForeColor.RGB = RGB(191, 191, 191)
.Fill.Transparency = 0
.Name = BoxName
With .Line
.Weight = 0
.ForeColor.RGB = RGB(191, 191, 191)
.Transparency = 0
End With ' Outline
With .TextFrame.TextRange
.Text = "Add. Info " & DisplayNumber & vbNewLine & AddName
With .Font
.Name = "Arial"
.Size = 8
.Bold = msoTrue
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.RGB = RGB(255, 255, 255)
End With ' Font
End With ' TextFrame
End With ' Square itself
End Sub
```
As of right now everything is red. I need everything after the colon to be black and not be Italic.
You just need to isolate the characters after the colon and set the colour as required:
EDIT: Forgot about the italic bit......
Sub test()
sCallOut = "ACTION: [Insert Callout Here]"
Set oShp = pptSld.Shapes.AddTextbox(msoTextOrientationHorizontal, 110, 100, 557.28, 94.32)
oShp.Line.Visible = msoFalse
oShp.TextFrame.TextRange.Text = sCallOut
oShp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
With oShp.TextFrame.TextRange.Font
.Name = "Corbel"
.Italic = msoTrue
.Size = 20
.Color.RGB = RGB(216, 3, 33)
.Bold = msoTrue
End With
With oShp.TextFrame.TextRange
With .Characters(InStr(.Characters, ":") + 1, .Length).Font
.Color.RGB = RGB(0, 0, 0)
.Italic = msoFalse
End With
End With
Set oShp = Nothing
End Sub
You can change this line to make the text black:
.Color.RGB = RGB(216, 3, 33)
And this line to remove italics:
.Italic = msoFasle
EDIT:
If you have the cell location, you can do this to the string later on:
With Cells(1, 1).Characters(9, 21).Font
.Color = vbBlack
.Italic = False
.Name = "Corbel"
.Size = 20
This shows how to use Characters
EDIT:
To change part of the text for a text box, you can declare two variables containing strings formatted differently and append them to the textbox.
It will follow the form:
MyTextBox.Value = MyStringVariable
or in your case:
MyTextBox.Value = MyStringVariable1 & MyStringVariable2
The macro recorder found the following:
Sub test()
ActiveSheet.Shapes.Range(Array("txtbox1")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"Choisir: wefhweufhwef 344tr saefaefa" 'Entering some text'
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 5).Font 'Selecting some font and changing some settings
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
End Sub
I haven't managed to do it without selecting the textbox first (?? maybe someone can help, usually it isn't hard). You can enter your text with a string in which you figure out the position of the colon using
dim MyString as string
dim intColon as integer
Mystring = "cwsvws:wifvwhivw"
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = MyString
intColon = instr(MyString, ":")
And use this as the character count to plug in the macro recorder's code. Then you can format different blocks of text how you want.
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(intColon, 5).Font
.Fill.ForeColor.RGB = RGB(0, 0, 255)
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
Hope this helps.
I have two(2) shapes. If shape1 is filled (red color) then the other one should not be filled and vice versa. I'm using the following code:
Dim sShape As Shape
Set sShape = ActiveSheet.Shapes(Application.Caller)
With sShape.Fill
If .Visible = True Then
.Visible = False
Else
.Visible = True
.ForeColor.RGB = RGB(255, 0, 0)
End If
End With
If sShape.Fill.ForeColor.RGB = RGB(255, 0, 0) = True Then
Range(Array("Rectangle 109")).Fill = False
Else
Range(Array("Rectangle 109")).Fill = True
Range(Array("Rectangle 109")).ForeColor.RGB = RGB(255, 0, 0)
End If
But it stops on Range(Array("Rectangle 109")).Fill = False.
Can anyone help me achieve what I want?
I have found the solution.
This has result in the follow Code:
Dim sShape As Shape
Set sShape = ActiveSheet.Shapes(Application.Caller)
With sShape.Fill
If .Visible = True Then
.Visible = False
With ActiveSheet.Shapes.Range(Array("Rectangle 109")).Fill
.Visible = True
.ForeColor.RGB = RGB(255, 0, 0)
End With
Else
.Visible = True
.ForeColor.RGB = RGB(255, 0, 0)
With ActiveSheet.Shapes.Range(Array("Rectangle 109")).Fill
.Visible = False
End With
End If
End With
At work I have 72 Excel 2010 workbooks in total, each with 12 sheets, with a chart on each sheet (I think this means the charts are not embedded?). I am a basic programmer having only covered VB at A-Level.
I need all charts (on the 12 seperate sheets) in a workbook to have the same coloured data lines as the first chart in that workbook.
My initial thoughts were to record a macro of me manually changing the line colours, thicknesses and so on then view the code for this macro and put some sort of loop around it.
After many hours trying different suggestions and many google searches I can't get it to work.
The code I have so far is as follows:
Sub Macro1()
Dim i As Integer
Dim sht As Worksheet
For i = 1 To ActiveWorkbook.Worksheets.Count
Set sht = ActiveWorkbook.Sheets(i)
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Legend.Select
ActiveChart.Legend.LegendEntries(1).Select
ActiveChart.SeriesCollection(1).Select
With Selection
.MarkerStyle = 2
.MarkerSize = 7
End With
Selection.MarkerStyle = -4168
Selection.Format.Fill.Visible = msoFalse
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
ActiveChart.Legend.Select
ActiveChart.Legend.LegendEntries(2).Select
ActiveChart.SeriesCollection(2).Select
With Selection
.MarkerStyle = 1
.MarkerSize = 7
End With
Selection.MarkerStyle = -4168
Selection.Format.Fill.Visible = msoFalse
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 112, 192)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 112, 192)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 112, 192)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
ActiveChart.Legend.Select
ActiveChart.Legend.LegendEntries(3).Select
ActiveChart.SeriesCollection(3).Select
With Selection
.MarkerStyle = 3
.MarkerSize = 7
End With
Selection.MarkerStyle = -4168
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
' .ForeColor.Brightness = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 112, 192)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
Selection.Format.Fill.Visible = msoFalse
ActiveChart.Legend.Select
ActiveChart.Legend.LegendEntries(4).Select
ActiveChart.SeriesCollection(4).Select
With Selection
.MarkerStyle = -4168
.MarkerSize = 7
End With
Selection.Format.Fill.Visible = msoFalse
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(112, 48, 160)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(112, 48, 160)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(112, 48, 160)
.Transparency = 0
End With
With Selection.Format.Line
.Visible = msoTrue
.Weight = 1.25
End With
Next i
End Sub
This code runs and does what I want but only on the worksheet you actually have open in excel, it will not run through and run the macro on each worksheet in the workbook. Any ideas?
Thanks in advance
You could call your Sub Macro1 from a loop that loops through all Worksheets.
For example:
Sub WorksheetLoop()
' Declare Current as a worksheet object variable.
Dim Current As Worksheet
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
' Insert your code here.
' This line displays the worksheet name in a message box.
MsgBox Current.Name
Next
End Sub
Then you can pass the Current Worksheet to your Function and run your code on that sheet.
For more info see: Macro to Loop Through All Worksheets in a Workbook
In this case you would change your code like this:
Sub Macro1(Byval Current As Worksheet)
Dim i As Integer
Dim sht As Worksheet
For i = 1 To ActiveWorkbook.Worksheets.Count
Set sht = Current
sht.ChartObjects("Chart 1").Activate
.....
End Sub
And create a loop like this:
Sub WorksheetLoop()
Dim Current As Worksheet
For Each Current In Worksheets
Call Macro1(Current)
Next
End Sub