How do I deactivate and reactivate several geometrical sets and objects automatically? - vba

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.

Related

PowerPoint vba group shapes using Shape objects, not shape names

I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub

vba Looping through Shape Listbox (change type)

So I have this spreadsheet with several listboxes. In these listboxes I have some values/items that are actually filters. I want to get each item/filter of each listboxes to amend an SQL query in my code.
So I've been asked to looped through the listboxes and I managed to do it by looping the Shapes of the spreadsheet but eventually ... those listboxes are now viewed as Shapes in VBA and not listboxes anymore. I'm looking for a way to either turn my shape in listbox or maybe find a method from the Shapes type to loop each listbox's items. Here is the part of my code, so far I loop through each shapes/listboxes, if within my shapes'name there is the word "CFRA" then I want to loop within each item selected of my listbox so that my function return them.
Private Function getListFilters() As String
My_Sheet.Activate
Dim Shp
For Each Shp In My_Sheet.Shapes
pos = InStrRev(Shp.Name, "CFRA", , vbTextCompare)
MsgBox (pos)
If pos <> 0 Then
MsgBox (TypeName(Shp))
End If
Next
End Function
Thanks in advance for those who are willing to help me and have a great day :)
Since you do not explain what is to be extracted from the list box, try the next Function, please. It will deliver the list box object having "CFRA" string in its name. Of course, any string can be used:
Private Function getListObjX(strPartName As String, sh As Worksheet) As MSForms.ListBox
Dim oObj As OLEObject
For Each oObj In sh.OLEObjects
If oObj.Name Like "*" & strPartName & "*" Then
'Debug.Print oObj.Name, TypeName(oObj.Object): Stop
If TypeName(oObj.Object) = "ListBox" Then
Set getListObjX = oObj.Object: Exit Function
End If
End If
Next
End Function
It can be called in the next way:
Sub testGetListObj()
Dim sh As Worksheet, lstB As MSForms.ListBox, lstBF As ListBox
Dim i As Long, arrSel As Variant, k As Long
Set sh = ActiveSheet
Set lstB = getListObjX("CFRA", sh)
If lstB Is Nothing Then MsgBox "No such an ActiveX list box...": Exit Sub
ReDim arrSel(lstB.ListCount - 1)
For i = 0 To lstB.ListCount - 1
If lstB.Selected(i) Then
'Debug.Print lstB.List(i)
arrSel(k) = lstB.List(i): k = k + 1
End If
Next i
ReDim Preserve arrSel(k - 1)
MsgBox Join(arrSel, "|")
End Sub
But, being an ActiveX list box type, you can simply use one of its events. Of course, if you do not need to take items from more then a list box...
I also prepared a function to return the object for a Form list box (before you clarify the issue). Maybe, somebody else will use it...
Dim oObj As ListBox
For Each oObj In sh.ListBoxes 'even not being shown by intellisense, this collection exists...
If oObj.Name Like "*" & strPartName & "*" Then
'Debug.Print oObj.Name
Set getListObjF = oObj: Exit Function
End If
Next
End Function
It can be called similarly, but the lstB should be declared As ListBox.
Edited, to make the function working in one step:
Private Function getListFilters(strPartName) As String
Dim sh As Worksheet, lstB As MSForms.ListBox
Dim oObj As OLEObject, i As Long, arrSel As Variant, k As Long
Set sh = ActiveSheet ' use here your sheet
For Each oObj In sh.OLEObjects
If oObj.Name Like "*" & strPartName & "*" Then
If TypeName(oObj.Object) = "ListBox" Then
Set lstB = oObj.Object: Exit For
End If
End If
Next
If lstB Is Nothing Then MsgBox "No such an ActiveX list box...": Exit Function
ReDim arrSel(lstB.ListCount - 1)
For i = 0 To lstB.ListCount - 1
If lstB.Selected(i) Then
arrSel(k) = lstB.List(i): k = k + 1
End If
Next i
ReDim Preserve arrSel(k - 1)
getListFilters = Join(arrSel, "|")
End Function
And the function will be simple called as:
Debug.Print getListFilters("CFRA")
You access ActiveX-Objects via the OLEObjects-Collection of a worksheet. The interesting control information are in the property Object of such an object:
Use VBA function TypeName to figure out what kind of OLE object you have
Number of items can be fetched with the Object.ListCount property.
To access the items of a listbox, loop over the Object.list property (index starts at 0, so loop must run from 0 to ListCount-1)
To check if an item is selected, use the matching .Object.Selected property.
The following code will loop will print all selected items of all listboxes of a worksheet:
Sub listBoxes()
Dim objx As OLEObject
For Each objx In ActiveSheet.OLEObjects
Debug.Print "Name = " & objx.Name & " Typ = " & TypeName(objx.Object)
If TypeName(objx.Object) = "ListBox" Then
Dim i As Long
For i = 0 To objx.Object.ListCount - 1
If objx.Object.Selected(i) Then
Debug.Print objx.Name, objx.Object.list(i)
End If
Next i
End If
Next
End Sub
Update: To show the coherence between Shapes, OleObjects and ActiceX controls on a sheet:
A Shape is a container for everything that is not part of a cell/range. Could be any kind of painted shape forms (rectangels, arrows, stars...), could be an image, a chart, an OLEObject, a form control and so on.
An OLEObject is a something that is not from Excel but is put into an Excel sheet, using a technique called OLE, Object Linking and Embedding.
An ActiveX is a control (editbox, listbox...). These controls where developed by Microsoft and where meant to run in different environments (eg a browser). They are accessible via dll and this dll is added into Excel and other office programs.
Every ActiveX-Control is added as an OLEObject into a sheet, but you can have also different OLEObjects (eg an embedded Word document) that are not an ActiceX objects.
When you want to access those things via VBA, you can use the Shapes-collection that lists all shapes of a sheet (including all OLEObjects), or you can use the OLEObjects-collection that lists all OLEObjects (including all ActiveX controls). However, there is no ActiveX collection, so if you want to fetch all ActiceX-Controls, you have to loop over either the two collections mentioned above.
If you want to access an OLEObject from the shape collection, you first need to check the type of the shape, it must have the type msoOLEControlObject (12) or msoEmbeddedOLEObject (7). A list of all shape types can be found here.
If the shape is either 7 or 12, you can access the OLEObject using Shape.OLEFormat.Object. The following to loops results in exactly the same (ws is just a worksheet variable)
Dim sh As Shape, oleObj As OLEObject
For Each sh In ws.Shapes
If sh.Type = msoOLEControlObject Or sh.Type = msoEmbeddedOLEObject Then
Set oleObj = sh.OLEFormat.Object
Debug.Print oleObj.Name, oleObj.OLEType
End If
Next
For Each oleObj In ws.OLEObjects
Debug.Print oleObj.Name, oleObj.OLEType
Next
Note that sh.Name and sh.OLEFormat.Object.Name are not necessarily the same.
Now the last step is to find the ActiveX-Controls of a specific type, this was already shown in the code of the original answer above - the ActiveX-control can be accessed via oleObj.object. Check the object type if the VBA function TypeName to filter out for example your listboxes.

How to find all shapes in a Visio drawing and add each shape to an array?

I am new to VBA and this is my first assignment, involving a pre-existing Visio drawing.
The Visio drawing consists of several shapes and I ultimately want a way to detect which shapes are cables (two "connector" shapes that are attached by a dynamic connector) using vba code. To do this,
1) I want to start by storing all the shape names in an array.
2) Then, I want to cross-check that array with know names of connector shapes and create a new array of just those connector shapes.
3) Next, I would check what each connector shape is connected to and that would allow me to determine what type of cable it is (I have this part of the code complete).
4) Finally, I would assign the cable's # to one of the connector shapes (I think I have working code for this too).
I am trying to figure out how to implement Steps 1 and 2 with my existing code.
Currently I am only able to detect connected shapes when one of those shapes is selected:
Public Sub ConnectedShapes()
' Get the shapes that are at the other end of
' incoming connections to a selected shape
Dim vsoShape As Visio.Shape
Dim allShapes As Visio.Shapes
Dim lngShapeIDs() As Long
Dim intCount As Integer
If ActiveWindow.Selection.Count = 0 Then
MsgBox ("Please select a shape that has connections.")
Exit Sub
Else
Set vsoShape = ActiveWindow.Selection(1)
End If
Set allShapes = ActiveDocument.Pages.Item(1).Shapes
lngShapeIDs = vsoShape.ConnectedShapes(visConnectedShapesAllNodes, "")
Debug.Print " Shape selected: ";
Debug.Print vsoShape
Debug.Print " Shape(s) connected: ";
For intCount = 0 To UBound(lngShapeIDs)
connectedItem = allShapes.ItemFromID(lngShapeIDs(intCount)).Name
Debug.Print connectedItem
If InStr(1, vsoShape, "USB A - top") = 1 Then
If InStr(1, connectedItem, "USB A Female") = 1 Then
' write cable's number
ElseIf InStr(1, connectedItem, "USB Mini B") = 1 Then
' write cable's number
ElseIf InStr(1, connectedItem, "USB Micro B") = 1 Then
' write cable's number
ElseIf InStr(1, connectedItem, "USB C Male") = 1 Then
' write cable's number
End If
End If
Next
End Sub
Is there a built-in function for Visio vba that would help me implement steps 1 & 2? What's the easiest way to find all the shapes in the document and store them in an array?
Understanding your desired business logic is the first step. Your steps 1 & 2 can be a single step.
Understanding your solution space is about understanding the range of tools a programming language gives you. In this case it is about how to efficiently loop (e.g. For Each) and information containers (e.g. Collection).
Here is some example code:
Option Explicit ' Always use this at the top of a module. Always.
Function ExampleFindShapes(chosenPage as Page) as Collection
Dim foundShapes as New Collection ' Note the new part, this initialised the Collection
Dim shapeLoopIterator as Shape
Dim arrayLoopIterator as Long
Dim validShapes as Variant
validShapes = Array("Bob", "Harry", "George")
For each shapeLoopIterator in chosenPage.Shapes ' One way to loop through an object collection
For arrayLoopIterator = LBound(validShapes) to UBound(validShapes) ' One way to loop through an array
If shapeLoopIterator.Name = validShapes(arrayLoopIterator) Then
foundShapes.Add shapeLoopIterator ' store the found shape as a reference to the shape
'Could put something in here to break out of the loop
End If
Next arrayLoopIterator
Next shapeLoopIterator
ExampleFindShapes = foundShapes
End Function
Coding from memory as I don't have Visio installed on this machine, so Page might be something else.
I have stored a reference to the shape instead of just the name, because the collection of found shapes will be easier to use in your parts 3 & 4, instead of you having to find and reference the shapes again.
The answer gets a little more complicated if you are working with grouped shapes. I suggest a new question referencing this one if this is the case as the answer will involve recursion and passing the collection down the line which a little more complex.

Transferring text range from 1 power point to another to change template

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.

extracting measurements from .catpart in CATIA V5

I have .CATPART and I have manually done measurements. I want to create macro using CAT VBA and extract measurements from .CATPART and export it to excel.
Sorry, measures stored in the part or product are not exposed to in the API.
I never found a solution for this, but here is a code that allow to get the measurements from the user selection. you can't parse all measurements, but you can select them and parse the selection (this example works only on one measurement selected, you'll have to adapt if possible for many):
Set oSelection = CATIA.ActiveDocument.Selection
On Error Resume Next
sName = oSelection.Item2(1).Value.Name
On Error Goto 0
'selection should be named with "catiabase"
If InStr(LCase(sName), "catiabase") = 0 Then Exit Function
'Get Name
'PROBLEM: This search will empty the selection if no measurement is selected
oSelection.Search "Name=Length,sel"
'No Length, no measurement (here i need only 1 selection)
If oSelection.Count2 <> 1 Then Exit Function
'Get name of measurement
sName = oSelection.Item2(1).Value.Name 'not the same as previous!
You can also find here a method to get distance value between two parts, but it requires to know the parts you want to get distances from
Imagining the simplest situation:
Sub CATMain()
''Get ActiveDocument
Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument
''Get Part
Dim part1 As Part
Set part1 = partDocument1.Part
''Get list of parameter of part
Dim oParams As Parameters
Set oParams = part1.Parameters
Dim PatternFind As String
PatternFind = "Measure"
''MsgBox all values of the parameter that contains 'Measure'
For Each item In oParams
If InStr(item.Name, PatternFind) <> 0 Then
MsgBox (item.Name & " = " & item.value)
End If
Next
End Sub
[View of tree view]
Part1
Measures
MeasureEdge.1
Length=10mm
MeasureEdge.2
Length=100mm
You should do the necessary modifications to export to Excel.