I'm trying to write a VBA macro that builds a basic diagram from data and certain template shapes (held on a separate page). While I can cut and paste successfully, I seem to be unable to reference the new shape after I do this. I can relocate the shape before I cut and paste it, but if I try to do anything after the fact, I hit a run-time error. There are various reasons why I might need to move / update the objects later, so I need to be able to subsequently reference them.
My code is as follows:
Dim Shape as Visio.Shape
Dim ShapeID as Integer
‘copy shape from template page 2, ID 12
Set Shape = Application.ActiveDocument.Pages.ItemU("Page-2").Shapes.ItemFromID(12).Duplicate
ShapeID = Shape.ID
MsgBox ("Created shape ID: " & ShapeID)
'Now relocate the shape appropriately
currentX = startX + (Count * xSpacing)
currentY = startY
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaForceU = "" & currentX & " mm"
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaForceU = "" & currentY & " mm"
Shape.Cut
'Now go to page 1 and paste the object
Application.ActiveDocument.Pages.ItemU("Page-1").Paste
‘*** THE FOLLOWING LINE THAT DOESN’T WORK ***
Set Shape = Application.ActiveDocument.Pages.ItemU("Page-1").Shapes.ItemFromID(ShapeID)
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaForceU = "" & currentX & " mm"
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaForceU = "" & currentY & " mm"
If I run the above, I get the error "Invalid sheet identifier" at the highlighted line (the shape is pasted successfully). If I cut this line out, I get "an exception occurred" on the following line, so it looks like I've lost my reference to the object.
A shape's ID is only unique to its page, so the new shape that you paste into Page-1 will receive a new ID and hence the error that you're receiving. Although the Duplicate method returns a shape reference to the new shape, Paste does not so you need to get a reference to it by other means - either assuming something about the window selection (as per Surrogate's answer) or by index:
Dim shp As Visio.Shape
Dim pag As Visio.Page
Set pag = ActivePage 'or some alternative reference to Page-1
Set shp = pag.Shapes.ItemU(pag.Shapes.Count)
Debug.Print shp.Index
A more usual workflow would be to generate masters (in a stencil document) and then drop those masters rather than copying and pasting between pages, but your scenario may require a different approach.
I'll add this link as useful reference for dealing with Index and ID properties:
Working with Shape Objects
[Update]
#Jon Fournier's comment below is quite right that the above does make assumptions. For example, if the DisplayLevel cell in the source shape is less than the top most shape then it will be pasted into the page's shapes collection at the corresponding index and so count won't return the correct shape ID.
An alternative approach might be to listen to the ShapeAdded event on Pages (or Page). The following is a slight adaption from the IsInScope example in the docs, with code placed ThisDocument. This allows you to top and tail your code in an event scope ID pair that you can inspect when handling the ShapeAdded event:
Private WithEvents vPags As Visio.Pages
Private pastedScopeID As Long
Public Sub TestCopyAndPaste()
Dim vDoc As Visio.Document
Set vDoc = Me 'assumes code is in ThisDocument class module, but change as required
Dim srcPag As Visio.Page
Set srcPag = vDoc.Pages.ItemU("Page-2")
Dim targetPag As Visio.Page
Set targetPag = vDoc.Pages.ItemU("Page-1")
Dim srcShp As Visio.Shape
Set srcShp = srcPag.Shapes.ItemFromID(12)
Set vPags = vDoc.Pages
pastedScopeID = Application.BeginUndoScope("Paste to page")
srcShp.Copy
targetPag.Paste
Application.EndUndoScope pastedScopeID, True
End Sub
Private Sub vPags_ShapeAdded(ByVal shp As IVShape)
If shp.Application.IsInScope(pastedScopeID) Then
Debug.Print "Application.CurrentScope " & Application.CurrentScope
Debug.Print "ShapeAdded - " & shp.NameID & " on page " & shp.ContainingPage.Name
DoSomethingToPastedShape shp
Else
Debug.Print "Application.CurrentScope " & Application.CurrentScope
End If
End Sub
Private Sub DoSomethingToPastedShape(ByVal shp As Visio.Shape)
If Not shp Is Nothing Then
shp.CellsU("FillForegnd").FormulaU = "=RGB(200, 30, 30)"
End If
End Sub
Of course you get error "Invalid sheet identifier" ! Because at "Page-1" you can have shape with ShapeID, which you defined for shape placed at "Page-2".
You can paste shape and after this step define selected shape.
Application.ActiveDocument.Pages.ItemU("Page-1").Paste
' You can define this variable as shape which is selected
Set Shape = Application.ActiveWindow.Selection.PrimaryItem
Why you use variable two times ?
I haven’t found a great way to handle this. I have a method that will paste the clipboard to a page and return any new shapes, by listing all shape ids before and after pasting, and then returning new shapes.
If speed is a big issue for me I’ll usually paste to an empty hidden page, do whatever I have to on that page, then cut and paste in place on the destination page. If you need to glue with other shapes this wouldn’t really work, but when it makes sense I use this logic.
Instead of Duplicate&Cut&Paste, just use Drop:
Dim srcShape, dstShape as Shape
Set srcShape = ActiveDocument.Pages("Page-2").Shapes("srcShape")
Set dstShape = ActiveDocument.Pages("Page-1").Drop(srcShape, 0, 0)
After the above you can access dstShape and do with it whatever you want.
Related
I wrote a macro that hides everything in several geometrical sets and the objects and geometrical sets in these first sets except one specific branch. I use this for saving a defined object of a huge and complicated specification tree as a STP file. (See attached below.)
(Small complication in this “Hide_and_Save” macro: adding bodies to my hide-selection works well but for my show-selection it didn’t work the same way. Why would this happen?)
I also wrote a macro that does iterative adjustments. For the iterations I use a Do While Loop and some parameters and measurements. To update these values, I have to update the part/object in every cycle. But there are some construction elements that issue errors until the loop is successfully completed. Therefore I deactivate all the geometrical sets that I don’t need for the iterations (inclusively all children) and later I reactivate them manually.
My goal is to improve automation, so I tried to use my “Hide_and_Save” macro for deactivation and reactivation. This didn’t work. When I record the process, each object is listed in a separate line and deactivated. Since there are more than 350 elements, I would like to avoid this.
How do I deactivate all subelements in a geometrical set (preferably with children) without addressing each element individually?
Attribute VB_Name = "Hide_and_Save"
'_______________________________________________________________________________________
'Title: Hide_and_Save
'Language: catvba
'_______________________________________________________________________________________
Sub CATMain()
'---------------------------------------------------------------------------------------
'Select active Part/Document
Dim myDocument As Document
Set myDocument = CATIA.ActiveDocument
Dim myPart As part
Set myPart = CATIA.ActiveDocument.part
'--------------------------------------------------------------
' Enter file path
Dim filepath As String
filepath = InputBox("Please select memory location", "Input filepath", "...")
If filepath = "" Then 'cancle, abort or empty input
MsgBox "No valid input / cancle !"
Exit Sub
End If
'--------------------------------------------------------------
' Hide/show Objects of Part/Products and save as STEP
' Update Model
CATIA.ActiveDocument.part.Update
' Deklaration of Selections and Properties
Dim selectionShow, selectionHide As Selection
Set selectionShow = myDocument.Selection
Set selectionHide = myDocument.Selection
Dim visPropertySetShow, visPropertySetHide As VisPropertySet
Set visPropertySetShow = selectionShow.VisProperties
Set visPropertySetHide = selectionHide.VisProperties
' Definition of the collection of geometric sets - HybridBodies
Dim hybridBodiesInPart, hybridBodiesInProcess As HybridBodies
Dim hybridBodiesInRS, hybridBodiesInHuelle As HybridBodies
' Definition of individual geometric sets - HybridBody
Dim hybridBodyInPart, hybridBodyProcess, hybridBodyInProcess As HybridBody
Dim hybridBodyRS, hybridBodyInRS As HybridBody
Dim hybridBodyHuelle, hybridBodyInHuelle As HybridBody
' Definition of the collection of 3D-objects - HybridShapes
Dim hybridShapesInHuelle As HybridShapes
' Definition of individual 3D-objects - HybridShape
Dim hybridShapeInHuelle, hybridShapeForm As HybridShape
' Hide objects
Set hybridBodiesInPart = myPart.HybridBodies
For Each hybridBodyInPart In hybridBodiesInPart
selectionHide.Add hybridBodyInPart
Next
Set hybridBodyProcess = hybridBodiesInPart.Item("Process")
Set hybridBodiesInProcess = hybridBodyProcess.HybridBodies
For Each hybridBodyInProcess In hybridBodiesInProcess
selectionHide.Add hybridBodyInProcess
Next
Set hybridBodyHuelle = hybridBodiesInProcess.Item("Huelle")
Set hybridBodiesInHuelle = hybridBodyHuelle.HybridBodies
For Each hybridBodyInHuelle In hybridBodiesInHuelle
selectionHide.Add hybridBodyInHuelle
Next
Set hybridShapesInHuelle = hybridBodyHuelle.HybridShapes
For Each hybridShapeInHuelle In hybridShapesInHuelle
selectionHide.Add hybridShapeInHuelle
Next
Set hybridShapeForm = hybridShapesInHuelle.Item("Form")
visPropertySetHide.SetShow 1 'hide
selectionHide.Clear
' Show objects
selectionShow.Add hybridBodyProcess
selectionShow.Add hybridBodyHuelle
selectionShow.Add hybridShapeForm
visPropertySetShow.SetShow 0 'show
selectionShow.Clear
' Data export as STP
stepAnswer = MsgBox("Should the displayed elements be saved as STEP?", 3 + 0, "Export: Form")
If stepAnswer = 6 Then
myDocument.ExportData filepath & "Form" & ".stp", "stp"
ElseIf stepAnswer = 3 Or stepAnswer = 2 Then 'cancle or abort
MsgBox "cancle !"
Exit Sub
End If
'---------------------------------------------------------------------------------------
MsgBox "Finished !" & vbCrLf & s
End Sub
(Usually I work with Generative Shape Design and use VBA for Macros.)
Each feature has an "Activity" parameter aggregated to it.
Dim oShape as HybridShape
For Each oShape In oGS.HybridShapes
Dim oActivity as Parameter
Set oActivity = oPart.Parameters.SubList(oShape,False).Item("Activity")
Call oActivity.ValuateFromString("False")
Next
Let me add that screwing with Activity of features is not a best practice. I NEVER do this myself. If you have access KBE (Specifically Knowledge Advisor Workbench) you can probably do what you want with Rules/Actions/Reactions, less coding and have a more robust model in the end.
I have a code to paste object from a slide to the active slide. How can I make the code to paste it inside the master instead?
Public Function AddShapeBooktitle()
Dim s As String, p As Presentation, o As Shape
'open the file and copy the object
If CommandBars.ActionControl.Parameter <> "" Then
s = Ini.GetResourcePath & CG_ADDIN_NAME & "\" & CG_INSERT_FOLDER & CG_BOOKTITLE_FOLDER & CommandBars.ActionControl.Parameter
Set p = Presentations.Open(s, ReadOnly:=True, WithWindow:=msoFalse)
p.Slides(1).Shapes.Range().Copy
p.Close
ActiveWindow.Selection.SlideRange(1).Shapes.Paste
Else
MsgBox "The Shape file name is missing.", vbExclamation, "Shape file name missing."
End If
End Function
Appreciate any pro help out there! Thanks!
You'll need to identify the current slide's custom layout, and then paste the shapes into the appropriate layout in the SlideMaster. Something like this works within a single presentation. If you're working between multiple presentations with potentially different SlideMaster collections, you may need to adjust the logic somehow. But this is the general idea: you need to identify which of the SlideMaster.CustomLayouts will be the destination for the Paste operation.
Option Explicit
Sub foo()
Dim p As Presentation
Dim sld As Slide
Dim layout As CustomLayout
Set p = ActivePresentation
Set sld = p.Slides(1)
layout = sld.CustomLayout.Index
sld.Shapes.Range().Copy
p.SlideMaster.CustomLayouts(layout).Shapes.Paste
End Sub
I'm in the process of automating the production of a PowerPoint report from and Excel spreadsheet. I've got the process working up until I paste a table.
I'm pasting the table to PowerPoint using PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting") and the table appears as a shape on my slide (the third shape).
To refer to the new shape I was using Set pShape = Slide2.Shapes(Slide2.Shapes.Count) but now now when I paste, the pShape is assigned "Shape 2" (not "Shape 3"). Is there something that needs to be done between the pasting and the assignment of the object?
Code below, commented where the issue occurs. (Full code removed; viewable here)
'Copy tables from Excel
Set rng = ws.Range("A:A")
rng.ColumnWidth = 22.75
Set rng = ws.Range("A4:C27")
'Copy the table range
Application.CutCopyMode = False
rng.Copy
Application.Wait (Now + TimeValue("0:00:02"))
'The issue occurs here!!! '-------------------------------------
'Paste the table in to the slide
Slide2.Select
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Name the new shape object
Set pShape = Slide2.Shapes(Slide2.Shapes.Count)
pShape.Name = "Slide_2_Table_1"
pShape.LockAspectRatio = False
'Shapes.Count' ≠ Shape Index# !
The .Count is not the same as the upper limit of current shape .Index numbers.
The numbering system is easier understood by listing all the shapes within the document:
Sub ListShapes()
'hit CTRL+G to view output in Immediate Window
Dim sh As Shape, sld As Slide, idx As Long
Set sld = ActivePresentation.Slides(1) '<-- change to your slide number
For Each sh In sld.Shapes
idx = idx + 1
Debug.Print "Shape ID#" & sh.Id, "Index #" & idx, "Name: " & sh.Name
Next sh
Debug.Print "Count of shapes: " & sld.Shapes.Count
End Sub
NOTE: There is alternative code for Excel at the bottom of this post!
To demonstrate, we can add shapes to a new document:
First, add one rectangle manually by clicking Insert (on the ribbon)
[If using Excel, click Illustrations], then Shapes, and the rectangle symbol.
Draw the shape, then hit Ctrl+C to copy it, and hit Ctrl+C four times to paste 4 copies.
Run the above procedure, and the output will be:
Shape ID#2 Index #1 Name: Rectangle 1
Shape ID#3 Index #2 Name: Rectangle 2
Shape ID#4 Index #3 Name: Rectangle 3
Shape ID#5 Index #4 Name: Rectangle 4
Shape ID#6 Index #5 Name: Rectangle 5
Count of shapes: 5
Note that the Index is not a property of this object, but it counted in order that Excel's storing the shapes in memory (same as the order returned by the For Each..Next statement.
You can prove this by running:
Debug.Print ActivePresentation.Slides(1).Shapes(5).Name
...which in this case return Rectangle 5.
Another way to understand how Excel is storing the shapes is with the Watch Window. Add a breakline or Stop in the middle of the loop, then highlight ws.Shapes, right-click it, choose Add Watch... and click OK. Browse through the tree to discover the varies properties/attributes of the shapes within the document.
Next, if we delete the "middle rectangle" and run the above procedure again, we will get:
Shape ID#2 Index #1 Name: Rectangle 1
Shape ID#3 Index #2 Name: Rectangle 2
Shape ID#5 Index #3 Name: Rectangle 4
Shape ID#6 Index #4 Name: Rectangle 5
Count of shapes: 4
The ID and Name of remaining shapes do not change, but the Index is renumbered to reflect the new "order".
...thus to return the name Rectangle 5 we now need to use:
Debug.Print ActivePresentation.Slides(1).Shapes(4).Name
Referring to shapes (including controls)
When you refer to a shape by number, like .Shapes(𝔁), you're referring to the shape Index Number 𝔁, not the ID number. Index numbers are dynamically assigned as needed as therefore are not a stable method to refer to a shape.
Therefore, .Count is irrelevant to the shape Index number.
Ideally, you should refer to the shape by the .Name or .ID number. If generating shapes dynamically, you'd ideally store a list of shapes in an array or collection, so you can look at the list as required.
Retrieve "Last Shape Created"
If the only reason for using the Index Number is to retrieve the "last shape created", then you could use a function like this to get the index number:
Function idxLastShape(slideNum As Long) As Long
Dim sh As Shape
For Each sh In ActivePresentation.Slides(slideNum).Shapes
idxLastShape = idxLastShape + 1
Next sh
End Function
Example Usage:
Debug.Print idxLastShape(1) 'Returns index of last shape on slide#1
NOTE: There is alternate code for Excel at the bottom of this post!
Alternatively, you could have the function return a reference to the actual shape object, rather than the number, like this:
Function LastShape(slideNum As Long) As Shape
Dim sh As Shape
For Each sh In ActivePresentation.Slides(slideNum).Shapes
Set LastShape = sh
Next sh
End Function
...so you could get the name of the "last shape" with:
Debug.Print LastShape(1).Name
Delete the most recently created shape
Using the function above, you can use any methods you would normally use with shapes. For example, you can delete the "last shape" that was created on Slide #1:
LastShape(1).Delete
CAUTION!
The examples in the post (including the deletion example!) are indiscriminate of what type of shape they're returning/editing/deleting!
There are dozens of types of shapes, from graphics to sound/video and controls. You can filter the shapes being enumerated by these procedures using the .Type property of the Shape object, as well as other methods. There is a partial list here, and more information in the links below.
Alternative code for Excel:
List all shapes on worksheet (Excel)
Sub ListShapes()
'hit CTRL+G to view output in Immediate Window
Dim sh As Shape, ws As Worksheet, idx As Long
Set ws = Sheets("Sheet1") '<-- change to your worksheet name
For Each sh In ws.Shapes
idx = idx + 1
Debug.Print "Shape ID#" & sh.ID, "Index #" & idx, "Name: " & sh.Name
Next sh
Debug.Print "Count of shapes: " & Sheets("Sheet1").Shapes.Count
End Sub
Return index number of "last shape" (Excel)
Function idxLastShape(shtName As String) As Long
Dim sh As Shape
For Each sh In Sheets(shtName).Shapes
idxLastShape = idxLastShape + 1
Next sh
End Function
Example Usage: Debug.Print idxLastShape("Sheet1")
Return reference to "last shape" object (Excel)
Function LastShape(shtName As String) As Shape
Dim sh As Shape
For Each sh In Sheets(shtName).Shapes
Set LastShape = sh
Next sh
End Function
Example Usage: Debug.Print LastShape("Sheet1").Name
More Information:
MSDN : Shapes Object (PowerPoint/VBA)
MSDN : Shapes Object (Excel/VBA)
MSDN : MsoShapeType Enumeration (Office)
Stack Overflow : Overview of working with Form Controls and ActiveX Controls
MSDN : Working with Shapes (Drawing Objects)
Office.com : How to add Shapes
BreezeTree : Programming Shapes (AutoShapes) with VBA
WiseOwl : Working with Shapes (Tutorial)
Other ways to copy from Excel to Powerpoint:
SpreadsheetGuru : Copy & Paste An Excel Range Into PowerPoint With VBA
ExcelOffTheGrid : Controlling Powerpoint from Excel using VBA
mvps.org : Paste Excel chart as pictures in PowerPoint (Paste Special)
I am very new with Powerpoint VBA and would like to know if there is a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B in a specific sequence.
Page a1 = b1
Page a2 = b2
Page a3 = b3
The template is changing and I need to adapt 5 powerpoints of 100 slides so I tought it would be easier with this solution.
Thank you in advance for your help.
PRECISION : I don't want to copy and paste the text range but to copy the text inside the range to put it inside the new range. Please find below the code I already have but It doesnt' Paste it inside my new range.
Sub copier_texte() 'je veux copier le contenu de la forme, et non pas la forme en entier
Dim nb_slide As Integer
nb_slide = ActivePresentation.Slides.Count
With ActivePresentation
.Slides(1).Shapes(2).TextFrame.TextRange.Copy 'je sélectionne uniquement le contenu de la forme
For i = 2 To .Slides.Count
.Slides(i).Select
ActiveWindow.View.Paste
Next i
End With
End Sub
Short Answer:
Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?
I think that there's no short way to do it, but let's try something first!
Long Answer:
Note: This solution based not on your desired behaviour (since it's unclear for me and there're many and more "what if" cases), but on similar problem, so I think that it's legit. Anyway it's a good fundament to start of.
Input:
I dont know how exactly your presentations looks like, so I made a reference one (Presentation A) and a "broken" one (Presentation B). Let's take a look on them:
Presentation A (5 slides: 1x"Title slide" with 2 triangle shapes, 3x"Title and Content" slides, 1x"Section Header" slide):
Presentation B (5 slides: 1x"Title slide" missing triangle shapes, 3x"Title and Content" slides with empty/without shapes(placeholders), 1x"Blank" slide (wrong layout)):
Both presentations are in the same folder:
Desired behaviour:
Some sort of synchronisation, if we miss a shape - then create one and put desired text to it, if there's one - put desired text only (based on Presentations A's shape). There're some "what if" cases in logic:
"What if" the number of slides in each presentation isn't equal? In which order compare slides then? (In our case the number is equal, so in code we drop that part and compare slides pair by pair).
"What if" the compared slides have a different layout? (In our case difference in blank layout, so we can easily handle it, but what we should do in general?)
...and many other cases not considered in this solution
Logic:
Logic is plain and simple. The entry point to our routine is in the Presentation A, since it's an our reference file. From that point we acquire a reference to Presentation B (when opening it), and start iteration in two loops (thru each pair of slides and thru reference shapes).
If we found a "broken" (or not so, there's no check for that) shape by a reference one - we put text and some options in it or create a new one shape (or placeholder) otherwise.
Option Explicit
Sub Synch()
'define presentations
Dim ReferencePresentation As Presentation
Dim TargetPresentation As Presentation
'define reference objects
Dim ReferenceSlide As Slide
Dim ReferenceSlides As Slides
Dim ReferenceShape As Shape
'define target objects
Dim TargetSlide As Slide
Dim TargetSlides As Slides
Dim TargetShape As Shape
'define other variables
Dim i As Long
'Setting-up presentations and slide collections
Set ReferencePresentation = ActivePresentation
With ReferencePresentation
Set TargetPresentation = Presentations.Open(FileName:=.Path & "/Presentation B.pptm", _
WithWindow:=msoFalse)
Set ReferenceSlides = .Slides
End With
Set TargetSlides = TargetPresentation.Slides
'Check slide count
If ReferenceSlides.Count <> TargetSlides.Count Then
'What's a desired behaviour for this case?
'We can add slides to target presentation but it adds complexity
Debug.Print "ERROR!" & vbTab & "Reference And Target slides counts are not equal!"
Else
'"mainloop" for slides
For i = 1 To ReferenceSlides.Count
Set ReferenceSlide = ReferenceSlides(i)
Set TargetSlide = TargetSlides(i)
'Check slide layout
If ReferenceSlide.Layout <> TargetSlide.Layout Then
'What's a desired behaviourfor this case?
'We can change layout for target presentation but it adds complexity
'But let's try to change a layout too, since we have an easy case in our example!
Debug.Print "WARNING!" & vbTab & "Reference And Target slides layouts are not same!"
TargetSlide.Layout = ReferenceSlide.Layout
End If
'"innerloop" for shapes (for placeholders actually)
With ReferenceSlide
For Each ReferenceShape In .Shapes
Set TargetShape = AcquireShape(ReferenceShape, TargetSlide, True)
If TargetShape Is Nothing Then
Debug.Print "WARNING!" & vbTab & "There's no shape like " & ReferenceShape.Name
ElseIf TargetShape.HasTextFrame Then
With TargetShape.TextFrame.TextRange
'paste text
.Text = ReferenceShape.TextFrame.TextRange.Text
'and options
.Font.Size = ReferenceShape.TextFrame.TextRange.Font.Size
.Font.Name = ReferenceShape.TextFrame.TextRange.Font.Name
.Font.Color.RGB = ReferenceShape.TextFrame.TextRange.Font.Color.RGB
'...
End With
End If
Next
End With
Next
End If
'Save and close target presentation
Call TargetPresentation.Save
Call TargetPresentation.Close
End Sub
Function AcquireShape(ByRef ReferenceShape As Shape, ByRef TargetSlide As Slide, _
Optional ByVal CreateIfNotExists As Boolean) As Shape
Dim TargetShape As Shape
With ReferenceShape
'seek for existed shape
For Each TargetShape In TargetSlide.Shapes
If TargetShape.Width = .Width And TargetShape.Height = .Height And _
TargetShape.Top = .Top And TargetShape.Left = .Left And _
TargetShape.AutoShapeType = .AutoShapeType Then
Set AcquireShape = TargetShape
Exit Function
End If
Next
'create new
If CreateIfNotExists Then
If .Type = msoPlaceholder Then
Set AcquireShape = TargetSlide.Shapes.AddPlaceholder(.PlaceholderFormat.Type, .Left, .Top, .Width, .Height)
Else
Set AcquireShape = TargetSlide.Shapes.AddShape(.AutoShapeType, .Left, .Top, .Width, .Height)
End If
End If
End With
End Function
Output:
I know that it's hard to find any difference by a screenshot (it's can be even photoshoped, anyway there're a few difference for that purpose), but for a full answer, here it is:
Conclusion:
As you see, it isn't a hard task to achieve something similar to your desire, but complexity of solution depends on inputs and on "what if" cases, hence there's no short way to overcome this task in general (in my humble opinion). Cheers!
Your question has a number of different interpretations, below is my attempt to answer what I believe the question is. There are a number of stage to this solution.
1. Ensure we save the VBA we write
Firstly, we have to assume a master presentation, that is one that will hold the values to be copied into all others. This will need to be saved as a macro enabled presentation (pptm) to allow us to save our VBA. This is done via File > Save-As and while selecting the save location choose PowerPoint Macro-Enabled Presentation in the Save as type box.
2. Enable Windows scripting runtime
Within the pptm 'master' presentation that we now have, open the VBA IDE (Alt+F11). In the menu bar select Tools > References... and tick Microsoft Scripting Runtime from the list that is presented. Click OK to close the references dialog box with your tick remembered. This is needed for some error handling in the code, it checks to see if the presentation exists before trying to open it.
3. Insert the provided code
Right-click on VBAProject in the upper right area (the Project explorer) and select Insert > Module.
In the main editing area paste the below (I have added commenting to describe what is happening): -
Option Explicit
Public Sub Update()
Dim AryPresentations(4) As String
Dim LngPID As Long
Dim FSO As New FileSystemObject
Dim PP_Src As Presentation
Dim PP_Dest As Presentation
Dim Sld_Src As Slide
Dim Sld_Dest As Slide
Dim Shp_Src As Shape
Dim Shp_Dest As Shape
Dim LngFilesMissing As Long
Dim BlnWasOpen As Boolean
'If there is an error, this will handle it and stop the process
On Error GoTo ErrorHandle
'Increase the size of AryPresentations and and the paths as shown in the example below
AryPresentations(0) = "C:\Users\garye\Desktop\PP2.pptx"
AryPresentations(1) = "C:\Users\garye\Desktop\PP3.pptx"
AryPresentations(2) = "C:\Users\garye\Desktop\PP4.pptx"
AryPresentations(3) = "C:\Users\garye\Desktop\PP5.pptx"
AryPresentations(4) = "C:\Users\garye\Desktop\PP6.pptx"
'PP_Src is this, our 'master' presentation
Set PP_Src = ActivePresentation
'This loops through each item in AryPresentations
For LngPID = 0 To UBound(AryPresentations, 1)
'We rememeber if you had it open already as if you did, then we won't close it when we are done
BlnWasOpen = False
'Check all currently open presentations to see if one if the presentation we are due to update
For Each PP_Dest In PowerPoint.Presentations
If Trim(UCase(PP_Dest.FullName)) = Trim(UCase(AryPresentations(LngPID))) Then Exit For
Next
'If it was not already open, check it exists and if it does, then open in
If PP_Dest Is Nothing Then
If FSO.FileExists(AryPresentations(LngPID)) Then
Set PP_Dest = PowerPoint.Presentations.Open(AryPresentations(LngPID))
End If
Else
BlnWasOpen = True
End If
If PP_Dest Is Nothing Then
Debug.Print "File note found"
LngFilesMissing = LngFilesMissing + 1
Else
'The below connects to the slide (Sld_Src) you want to pick up from, the shape (Shp_Src) you want to pick up from and then
'places it in the slide (Sld_Dest) you want it to go to into the shape (Shp_Dest) you want it to go in to
Set Sld_Src = PP_Src.Slides(1)
Set Sld_Dest = PP_Dest.Slides(1)
Set Shp_Src = Sld_Src.Shapes(1)
Set Shp_Dest = Sld_Dest.Shapes(1)
Shp_Dest.TextFrame.TextRange.Text = Shp_Src.TextFrame.TextRange.Text
Set Shp_Dest = Nothing
Set Shp_Src = Nothing
Set Sld_Dest = Nothing
Set Sld_Src = Nothing
'Repeat the above for each piece of text to copy
'Finally save the changes
PP_Dest.Save
'Close the presentation if it was not already open
If Not BlnWasOpen Then PP_Dest.Close
End If
Next
MsgBox "Process complete. Number of missing files: " & LngFilesMissing, vbOKOnly + vbInformation, "Complete"
Exit Sub
ErrorHandle:
MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error"
Err.Clear
End Sub
4. Customise code
You'll want to add the paths and location of the changes in and then it should run.
Can I get the name of the layer a connector is assigned to in vba?
I am doing this with shapes like this
ActivePage.Shapes(1).layer(1)
And now I am looking for something similar but for connectors.
I'm not completely clear on your issue, but there's nothing special about connectors - they're still just shapes. So if you know the index of your target shape and layer, then you can use your code above.
Shapes in Visio can also belong to multiple layers (layers don't work in the same way as, say, Photoshop), so you might want to get the layer count first and then run through each one. For example:
Sub CheckLayers()
Dim shp As Visio.Shape
Dim i As Integer
For Each shp In ActivePage.Shapes
Debug.Print shp.NameU
For i = 1 To shp.LayerCount
Debug.Print " " & shp.Layer(i).Name
Next i
Debug.Print ""
Next shp
End Sub
Also, depending on what you're trying to do, you might want to take advantage of the Page.CreateSelection method to return a selection based on shapes on a particular layer. Here's a very slightly modified version from the Visio SDK:
Public Sub CreateSelection_Layer_Example()
Dim vsoLayer As Visio.Layer
Dim vsoSelection As Visio.Selection
Set vsoLayer = ActivePage.Layers.ItemU("Connector")
Set vsoSelection = ActivePage.CreateSelection(visSelTypeByLayer, visSelModeSkipSuper, vsoLayer)
'Note that you don't have to pass the selection object to
'the ActiveWindow Selection property - you can just work
'with it directly if you want to
Application.ActiveWindow.Selection = vsoSelection
End Sub
If you're using the Dynamic Connector, this gets automatically assigned to a layer called 'Connector'.