I am using a small VBA program to apply some text in the background. I am able to apply watermark but if I use any image in the presentation then the watermark goes behind that image. Is there any way to keep the watermark always in front.
I am using this code to apply watermark :
Dim cntDesigns As Integer
cntDesigns = ActivePresentation.Designs.Count
For iter = 1 To cntDesigns
Dim curDesign As Design
Set curDesign = ActivePresentation.Designs.Item(iter)
' EnumerateMasters
Dim masterCount As Integer
masterCount = 1
Dim masters(100) As Master
Set masters(masterCount) = curDesign.SlideMaster
Dim cntLayouts As Integer
cntLayouts = curDesign.SlideMaster.CustomLayouts.Count
For Layout = 1 To cntLayouts
Dim curLayout As CustomLayout
Set curLayout = curDesign.SlideMaster.CustomLayouts(Layout)
If curLayout.DisplayMasterShapes = msoFalse Then
masterCount = masterCount + 1
Set masters(masterCount) = curLayout
End If
Next Layout
For masterIter = 1 To masterCount
Dim shape As shape
Set shape = masters(masterIter).Shapes.AddTextbox(msoTextOrientationHorizontal, 0#, 0#, 100#, 100#)
shape.TextEffect.Text = "Watermark"
shape.Height = 100
shape.Width = 100
shape.TextFrame2.WordWrap = msoTrue
shape.TextFrame2.WarpFormat = msoWarpFormat1
shape.Left = 100
shape.Top = 200
Next masterIter
Next iter
No, anything you put on top of something will cover it up. There's no "Keep this shape on top" command.
You can, however, trap one or more events that are likely to happen often (selection change, for example) and let that event trigger code that looks at each shape on the slide(s) and moves your watermark shape to front if it's not already there.
Related
I have used VBA in the past mostly with excel, but I am not very experienced.
I want to cycle through multiple boxes and make each of them have coincident edges. Like they are sitting on top of each other. I am having trouble identifying the position of the first shape in my selection. I've tried a number of different objects including selection.shaperange.
Dim shp As Visio.Shape
Dim shp1 As Visio.Shape
Dim Pos As Double
Set shp1 = ActiveWindow.Selection.ShapeRange.Item
Pos = shp1.Cells("PinY")
For Each shp In Application.ActiveWindow.Selection
'Change the cell name to the one you want
If shp <> ActiveWindow.Selection.Item(1) Then
Pos = Pos + 6
End If
shp.CellsSRC(visSectionControls, visRowXFormOut, visXFormPinY).FormulaU = Pos & "mm"
Pos = shp.Cells("PinY")
Next shp
End Sub
Can you help me get the position of the first selected item and then I may be able to figure out the rest.
This code will abut the left sides of all but the first-selected shape with the right side of the first-selected shape:
Option Explicit
Public Sub AbutLeftsToPrimaryRight()
Dim sel As Visio.Selection
Set sel = Visio.ActiveWindow.Selection
If (sel.Count < 2) Then
Debug.Print "Select two or more shapes (Use Shift + Click)!"
GoTo Cleanup
End If
Dim shp0 As Visio.Shape
Dim shp As Visio.Shape
'// Get the selection and the primary selected shape,
'// which is item(1). See also: Selection.PrimaryItem
Set shp0 = sel(1)
'// Quick calculate the right side of shp0:
'// PinX - LocPinX + Width.
Dim dRight0 As Double
dRight0 = shp0.CellsU("PinX").ResultIU - shp0.CellsU("LocPinX").ResultIU + shp0.CellsU("Width").ResultIU
'// If shapes are rotated, flipped, or not rectangular,
'// then you'll need to use shp.BoundingBox, which
'// is more complicated
Dim dLeft As Double
Dim dx As Double, px As Double
Dim i As Integer
For i = 2 To sel.Count
'// Get the ith shape:
Set shp = sel(i)
'// Get its Pin:
px = shp.CellsU("PinX").ResultIU
'// Calculate the left side of the shape:
'// PinX - LocPinX:
dLeft = px - shp.CellsU("LocPinX").ResultIU
'// The offset:
dx = dLeft - dRight0
'// Set the new pin:
shp.CellsU("PinX").ResultIUForce = px - dx
Next i
Cleanup:
Set shp0 = Nothing
Set shp = Nothing
Set sel = Nothing
End Sub
Hope this helps!
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 want to glue a shape to another one via VBA.
All the shapes are created with an UserForm Module.
I want certain shapes to be connected with an arrow (which is also dropped on the page via an UserForm). It works fine connecting two shapes which are not in a group. Now I want to connect two shapes where one or both of them may be in a Group.
This works fine with non-grouped shapes
'get shp, src, aim
[...]
shp.Cells("BeginX").GlueTo src.Cells("PinX")
shp.Cells("EndX").GlueTo aim.Cells("PinX")
I get the aim and src Shapes using this function:
Function getShape(id As Integer, propName As String) As Shape
Dim shp As Shape
Dim subshp As Shape
For Each shp In ActivePage.Shapes
If shp.Type = 2 Then
For Each subshp In shp.GroupItems
If subshp.CellExistsU(propName, 0) Then
If subshp.CellsU(propName).ResultIU = id Then
Set getShape = subshp
Exit For
End If
End If
Next subshp
End If
If shp.CellExistsU(propName, 0) Then
If shp.CellsU(propName).ResultIU = id Then
Set getShape = shp
Exit For
End If
End If
Next
End Function
I think there is something wrong with how I iterate through the subshapes.
Any help is appreciated.
Ah, #Surrogate beat me to it :) but since I've started writing...in addition to his answer, which shows nicely how to adapt the built in Dynamic connector here's a go with your group finding method + a custom connector.
The code assumes a few things:
a page with two 2D shapes already dropped
one of the shapes is a group shape containing a subshape with the correct Shape Data
A custom master named 'MyConn' which is simple a 1D line with no other modifications
Public Sub TestConnect()
Dim shp As Visio.Shape 'connector
Dim src As Visio.Shape 'connect this
Dim aim As Visio.Shape 'to this
Dim vPag As Visio.Page
Set vPag = ActivePage
Set shp = vPag.Drop(ActiveDocument.Masters("MyConn"), 1, 1)
shp.CellsU("ObjType").FormulaU = 2
Set src = vPag.Shapes(1)
Set aim = getShape(7, "Prop.ID")
If Not aim Is Nothing Then
shp.CellsU("BeginX").GlueTo src.CellsU("PinX")
shp.CellsU("EndX").GlueTo aim.CellsU("PinX")
End If
End Sub
Function getShape(id As Integer, propName As String) As Shape
Dim shp As Shape
Dim subshp As Shape
For Each shp In ActivePage.Shapes
If shp.Type = 2 Then
For Each subshp In shp.Shapes
If subshp.CellExistsU(propName, 0) Then
If subshp.CellsU(propName).ResultIU = id Then
Set getShape = subshp
Exit For
End If
End If
Next subshp
End If
If shp.CellExistsU(propName, 0) Then
If shp.CellsU(propName).ResultIU = id Then
Set getShape = shp
Exit For
End If
End If
Next
End Function
Note that if you read the docs for Cell.GlueTo, you'll see this item:
The pin of a 2-D shape (creates dynamic glue): The shape being glued
from must be routable (ObjType includes visLOFlagsRoutable ) or have a
dynamic glue type (GlueType includes visGlueTypeWalking ), and does
not prohibit dynamic glue (GlueType does not include
visGlueTypeNoWalking ). Gluing to PinX creates dynamic glue with a
horizontal walking preference and gluing to PinY creates dynamic glue
with a vertical walking preference.
and hence why I'm setting the ObjType cell to 2 (VisCellVals.visLOFlagsRoutable). Normally you'd set this in your master instance and so wouldn't need that line of code.
Please try this code
Dim connector As Shape, src As Shape, aim As Shape
' add new connector (right-angle) to page
Set connector = Application.ActiveWindow.Page.Drop(Application.ConnectorToolDataObject, 0, 0)
' change Right-angle Connector to Curved Connector
connector.CellsSRC(visSectionObject, visRowShapeLayout, visSLOLineRouteExt).FormulaU = "2"
connector.CellsSRC(visSectionObject, visRowShapeLayout, visSLORouteStyle).FormulaU = "1"
Set src = Application.ActiveWindow.Page.Shapes.ItemFromID(4)
Set aim = Application.ActiveWindow.Page.Shapes.ItemFromID(2)
Dim vsoCell1 As Visio.Cell
Dim vsoCell2 As Visio.Cell
Set vsoCell1 = connector.CellsU("BeginX")
Set vsoCell2 = src.Cells("PinX")
vsoCell1.GlueTo vsoCell2
Set vsoCell1 = connector.CellsU("EndX")
Set vsoCell2 = aim.Cells("PinX")
vsoCell1.GlueTo vsoCell2
I have a simple question, but i can not find the answer. For my job i have to make print sheets of 150x200 cm. Within these sheets a number of copies that are set border to border to fill out the sheet. Then we will print it.
Now i always start with one copy on the artboard, set my cut lines, group them up and to get the number of copies i want, i manually copy them with ctrl+shift+Alt (and CTRL+D ) to fill the artboard in width and length.
Now i was wondering if there is a tool or script where i can tell illustrator that i want 100 copies border to border and it automatically fills my artboard with the copies.
Any ideas?
AI has a rich object model. The object model allows to do everything you can do manually, and much more. Object model guides can be downloaded from the Adobe official web site.
The object model can be accessed from any programming or script language that supports automation. Examples include any modern C language IDEs, VBA, JavaScript and many others.
The thing you are looking for is the Duplicate method. The Duplicate method works times faster than Copy/Paste. The Duplicate method can be applied to many AI objects such as paths, group items, raster images, text frames etc.
The VBA code below draws a pattern and then fills the sheet with this pattern. You can use this code a basic tutorial for accessing the AI object model. Just open the VBA editor from any MS Office app, paste and run the code.
Good luck!
Option Explicit
Const CM2PT As Double = 28.3465
Const DOC_W As Double = 15# ' Document width (cm)
Const DOC_H As Double = 20# ' Document height (cm)
' NB: The combination of PATTERN_W, PATTERN_H, PAD_W, PAD_H should
' conform the Netherlands flag proportions 3:2
Const PATTERN_W As Double = 3# ' Pattern width (cm)
Const PATTERN_H As Double = 2# ' Pattern height (cm)
Const PAD_W As Double = 3# ' Flag pad width (pt)
Const PAD_H As Double = 2# ' Flag pad height (pt)
Sub Test()
Dim aiApp As Object ' Illustrator.Application
Dim aiDoc As Object ' Illustrator.Document
Dim aiPath As Object ' Illustrator.PathItem
Dim srcGroup As Object ' Illustrator.GroupItem
Dim dstGroup As Object ' Illustrator.GroupItem
Dim StripeColor_1 As Object ' Illustrator.RGBColor
Dim StripeColor_2 As Object ' Illustrator.RGBColor
Dim StripeColor_3 As Object ' Illustrator.RGBColor
Dim FrameColor As Object ' Illustrator.RGBColor
Dim Stripe_L As Double ' Left of a flag stripe (pt)
Dim Stripe_T As Double ' Top of a flag stripe (pt)
Dim Stripe_H As Double ' Height of a flag stripe (pt)
Dim Stripe_W As Double ' Width of a flag stripe (pt)
Dim i As Long
Dim j As Long
'*******************************************************************************
' Init
'*******************************************************************************
On Error Resume Next
Set aiApp = CreateObject("Illustrator.Application") ' Late binding
' Set aiApp = New Illustrator.Application ' Early binding
If (Err <> 0) Then Exit Sub
Set aiDoc = aiApp.Documents.Add(1, CM2PT * DOC_W, CM2PT * DOC_H) ' 1 = AiDocumentColorSpace.aiDocumentRGBColor
If (Err <> 0) Then Exit Sub
Set StripeColor_1 = CreateObject("Illustrator.RGBColor")
Set StripeColor_2 = CreateObject("Illustrator.RGBColor")
Set StripeColor_3 = CreateObject("Illustrator.RGBColor")
Set FrameColor = CreateObject("Illustrator.RGBColor")
Set srcGroup = aiDoc.GroupItems.Add
On Error GoTo 0
'*******************************************************************************
' Draw the flag of Netherlands
'*******************************************************************************
Stripe_L = PAD_W
Stripe_T = aiDoc.Height - PAD_H
Stripe_H = (CM2PT * PATTERN_H - 2 * PAD_H) / 3
Stripe_W = CM2PT * PATTERN_W - 2 * PAD_W
' Top stripe = Bright Vermilion RGB(174, 28, 40)
StripeColor_1.Red = 174
StripeColor_1.Green = 28
StripeColor_1.Blue = 40
' Center stripe = White RGB(255, 255, 255)
StripeColor_2.Red = 255
StripeColor_2.Green = 255
StripeColor_2.Blue = 255
' Bottom stripe = Cobalt Blue RGB(33, 70, 139)
StripeColor_3.Red = 33
StripeColor_3.Green = 70
StripeColor_3.Blue = 139
' Frame color = Black
FrameColor.Red = 0
FrameColor.Green = 0
FrameColor.Blue = 0
' Top stripe
Set aiPath = aiDoc.PathItems.Rectangle(Stripe_T, Stripe_L, Stripe_W, Stripe_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_1
aiPath.Stroked = False
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
' Center stripe
Set aiPath = aiDoc.PathItems.Rectangle(Stripe_T - Stripe_H, Stripe_L, Stripe_W, Stripe_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_2
aiPath.Stroked = False
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
' Bottom stripe
Set aiPath = aiDoc.PathItems.Rectangle(Stripe_T - 2 * Stripe_H, Stripe_L, Stripe_W, Stripe_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_3
aiPath.Stroked = False
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
' The cover
Set aiPath = aiDoc.PathItems.Rectangle(aiDoc.Height, 0, CM2PT * PATTERN_W, CM2PT * PATTERN_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_2
aiPath.Opacity = 50#
aiPath.Stroked = True
aiPath.StrokeColor = FrameColor
aiPath.StrokeWidth = 0.25
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
'*******************************************************************************
' Duplicate
'*******************************************************************************
For i = 1 To DOC_H / PATTERN_H
For j = 1 To DOC_W / PATTERN_W
Set dstGroup = srcGroup.Duplicate
dstGroup.Left = PATTERN_W * CM2PT * (j - 1)
dstGroup.Top = aiDoc.Height - PATTERN_H * CM2PT * (i - 1)
Next
Next
Call srcGroup.Delete
'*******************************************************************************
' Finish
'*******************************************************************************
FINISH:
Set StripeColor_1 = Nothing
Set StripeColor_2 = Nothing
Set StripeColor_3 = Nothing
Set FrameColor = Nothing
Set aiDoc = Nothing
Set aiApp = Nothing
End Sub
I'm trying to make text in the data label of the chart with shadow effect (that shadow effect which you have at top of the PowerPoint menu), but I'm unable to make it work, dataLabels.shadow or dataLabels.font.shadow makes the frame shadowed, not the text.
I was googling a lot, I have found out this could be possible via TextFormat or TextFormat2 property, unfortunately I'm not able to access it for the text in the data label anyhow. My current code, lines after comment does not work:
For Each Shape In Slide.Shapes
If Shape.HasChart Then
Dim i As Integer
Dim v As Variant
Set pts = Shape.Chart.SeriesCollection(1).Points
For Each s In Shape.Chart.SeriesCollection
v = s.Values
If s.Name <> "XXX_XXX" Then
If v(pts.Count) >= 0.05 Then
s.Select
s.Points(pts.Count).Select
s.Points(pts.Count).ApplyDataLabels
s.DataLabels.Font.Color = s.Border.Color
s.DataLabels.Font.Size = 20
s.DataLabels.Font.Name = "Calibri"
's.DataLabels.Shadow = True
's.DataLabels.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel(pts.Count).TextFrame.TextRange.Font.Shadow = msoTrue
End If
End If
Next s
End If
Next Shape
If someone will have problems with simillar case I have found the answer :)
The shadow (ribbon like shadow) for data label text/value is done via TextRange2 property, but I was missing Format. Like this :
Dim tr As TextRange2
Set tr = s.DataLabels(pts.Count).Format.TextFrame2.TextRange
With tr.Font.Shadow
.OffsetX = 10
.OffsetY = 10
.Size = 1
.Blur = 4
.Transparency = 0.5
.Visible = True
End With