I would like to be able to loop through a set of shapes that have the prop.shapekey name in the format 1- and 2- then 3- etc. When the shape is selected I would like to send it to the back and then loop onto the next one.
Is this possible and if so how?
Many thanks
Miles
You need to loop through all shapes on the page, for each shape check whether the shape data entry exists, if it does then check the data contents.
In addition, if the shapes in question might be nested, i.e., subshapes, then your search needs to be recursive to work thru the nesting structure.
Wow, that could take some time! :) I have a few thousand shapes on the page and i am targeting 300 x3 of them (1- to 300-, 1BL to 300BL and 1-p to 300-p) I will have to see how slow this runs! :)
Are there any tricks you can suggest to speed up Visio code? One that springs to mind is to cut out of the loop as soon as a match is found.
Thanks for the confirmation and any further hints you have :)
Miles
Might not be too bad, but a lot of shapes means a lot of checking, and then a lot of whatever needs to be done with each catch. Still, better than doing this manually.
You might speed up the process by quickly condensing the number of candidate shapes with filtering. For example, have the code ignore 1D shapes.
Also, it you edit shapes on the document stencil, those will flush into respective shapes on the drawing page.
Attached is sample file using code to search the document sheet for Rectangle masters and then changes their color. Only the one, correct master is actually processed. The changes are automatically flushed into the numerous Rectangle shapes placed on the drawing page.
Open the code window and the then use <f8> to step thru the macro. The code skips the majority of the shapes and only makes processes the desired shapes, saving execution time.
Quote from: wapperdude on January 07, 2022, 07:09:18 AM
Attached is sample file using code to search the document sheet for Rectangle masters and then changes their color. Only the one, correct master is actually processed. The changes are automatically flushed into the numerous Rectangle shapes placed on the drawing page.
Open the code window and the then use <f8> to step thru the macro. The code skips the majority of the shapes and only makes processes the desired shapes, saving execution time.
OK, allow me to check my understanding and the possible implications for what I am trying to do. Your code:
* makes a new stencil of masters which are on the page
* Cycles through these checking if the name = rectangle
* Changes the master colour for "rectange"
* closes the new stencil
And the change is pushed out to all shapes which are based on the master by the nature of the master / shape relationship.
This would be very useful if I was making changes to the shapes as I could arrange for all shapes on a "layer" (I know they're not "on" a layer but it is easier to say it!:) ) to have the same master and then changes would be quick and easy to make. I don't understand how this would help me to shorten the task of searching for ShapeRef= "1-" for instance amongst all the shapes on the page. I can arrange for all shapes which will have ShapeRef of 1- or 2- or 300- to have the same master but does this help in the task of finding 1- on the page?
You can also split the process into two steps:
1 - create a sorted collection and save it in the document.
2 - search for a shape in a sorted collection.
Step 1 will take a long time, but rarely. For example, using a separate "Refresh List" macro.
Step 2 will be performed frequently and quickly. Searching a sorted collection is much faster than checking all shapes on a page or document.
The sorted collection can be saved in the "Data1" field as a delimited list or in SolutionXML.
Quote from: Croc on January 10, 2022, 04:55:44 PM
You can also split the process into two steps:
1 - create a sorted collection and save it in the document.
2 - search for a shape in a sorted collection.
Step 1 will take a long time, but rarely. For example, using a separate "Refresh List" macro.
Step 2 will be performed frequently and quickly. Searching a sorted collection is much faster than checking all shapes on a page or document.
The sorted collection can be saved in the "Data1" field as a delimited list or in SolutionXML.
I don't know about collections. Does the "saved collection" survive the file being closed and re-opened or is the lifespan of the collection as long as the file is open? When you search for the item in the sorted collection I assume you are finding the actual item so that it can be selected and sent to the back etc?
Also do collections need any settings etc to be enabled on the users' machine?
Many thanks
Miles
Currently, my brute force and ignorance solution which cycles through 1.5K - 2K shapes 300 times to identify the things that need to be selected and then sent to the back in a sequence is shown below. This takes 1.5-2 minutes which I would love to speed up.
Sub ReOrder_including_within_layer()
Dim shp As Visio.Shape
Dim ShapeKey As String
Application.ScreenUpdating = False
Application.DeferRecalc = True
ActiveWindow.DeselectAll
For N = 300 To 1 Step -1
For Each shp In ActivePage.Shapes
If shp.CellExistsU("Prop.ShapeKey", 0) Then ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
ActiveWindow.Select shp, visSelect
End If
Next shp
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
Next N
ActiveWindow.DeselectAll
'Call ReOrder_Layers
Finalise:
ActiveWindow.DeselectAll
Application.ScreenUpdating = True
Application.DeferRecalc = False
End Sub
Adding 1 more IF statement might help, if (pun intended) your pages have connector and/or lines, that is, OneD shapes. The new IF statement immediately excludes these shapes from additional processing.
For N = 300 To 1 Step -1
For Each shp In ActivePage.Shapes
If Not shp.OneD Then
If shp.CellExistsU("Prop.ShapeKey", 0) Then ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
ActiveWindow.Select shp, visSelect
End If
End If
Next shp
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
Next N
Quote from: miless2111s on January 10, 2022, 08:51:35 PM
Currently, my brute force and ignorance solution which cycles through 1.5K - 2K shapes 300 times to identify the things that need to be selected and then sent to the back in a sequence is shown below. This takes 1.5-2 minutes which I would love to speed up.
[/quote
In Reply #9, do you have a copy/paste error in the code, specifically this line: If shp.CellExistsU("Prop.ShapeKey", 0) Then ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
Seems odd. Didn't test correctly. Ignoring my OneD IF construct, and some abbreviations, I believe you intended it to read as follows:
For Each shp In ActivePage.Shapes
If Not shp.OneD Then 'ignore 1D shapes
If shp.CellExistsU("Prop.Key", 0) Then 'ignore shapes lacking Prop.Key, I abbreviated your entry for my testing
ShapeKey = shp.Cells("Prop.Key").ResultStr("")
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
ActiveWindow.Select shp, visSelect
End If
End If
End If
Next shp
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
QuoteI don't know about collections. Does the "saved collection" survive the file being closed and re-opened or is the lifespan of the collection as long as the file is open? When you search for the item in the sorted collection I assume you are finding the actual item so that it can be selected and sent to the back etc?
Also do collections need any settings etc to be enabled on the users' machine?
Here is an example of saving a list of target shapes in the Date1 field. If the number of target shapes is significantly less than the number of all shapes, then such a technique can give a gain in terms of the execution time of the work operation.
The Date1 field belongs to the document and is saved with it.
The example contains an unsorted collection. Sorting is optional but can sometimes provide an added benefit.
Dim c As Collection
Public Sub RefreshData1() 'Executed once
Set c = New Collection
For Each shp In ActivePage.Shapes
'There must be some filter (If Prop. exists etc)
c.Add shp.NameID
Next
Call CollectionToData1
' Now ActiveDocument.DocumentSheet.Data1 contains only the NameId list of target shapes
End Sub
Public Sub WorkOperation() 'Executed multiple times
Call CollectionFromData1
For Each itm In c 'NameId of target shapes only
Debug.Print ActivePage.Shapes(itm).NameID
Next
End Sub
Private Sub CollectionToData1()
s = ""
For Each itm In c
s = s & itm & ";"
Next
ActiveDocument.DocumentSheet.Data1 = s
End Sub
Private Sub CollectionFromData1()
s = ActiveDocument.DocumentSheet.Data1
Set c = New Collection
Arr = Split(s, ";")
For i = LBound(Arr) To UBound(Arr) - 1
c.Add Arr(i)
Next
End Sub
Quote from: Croc on January 11, 2022, 07:39:36 AM
Here is an example of saving a list of target shapes in the Date1 field. If the number of target shapes is significantly less than the number of all shapes, then such a technique can give a gain in terms of the execution time of the work operation.
The Date1 field belongs to the document and is saved with it.
The example contains an unsorted collection. Sorting is optional but can sometimes provide an added benefit.
Croc, thank you for the example and explanation. I sounds like this might be a very useful approach. Am I right in thinking that I would use the structure of "Sub WorkOperation()" and replace "For Each shp In ActivePage.Shapes" in my code with your "For Each itm In c " and this will find each specific shape in C, test it to see if it contains "1-" or "1--p" etc and then execute the code rather faster as it is looking through a rather smaller set (1500 items rather than thousands) 300 times?
many thanks
Miles
Yes, you got the idea right.
Quote from: wapperdude on January 10, 2022, 09:42:50 PM
Adding 1 more IF statement might help, if (pun intended) your pages have connector and/or lines, that is, OneD shapes. The new IF statement immediately excludes these shapes from additional processing.
One of the target shape sets is a line so I don't think I can use that, thank you for the If/End if catch; you are right your edit is neater and more correct :) In my testing, it didn't make any errors (what did you see when you say it didn't test properly?) however your way is better.
Quote from: Croc on January 11, 2022, 09:15:21 AM
Yes, you got the idea right.
Great, I'll have a crack at that later :)
what is the difference between NameID and Name? When I search using the Edit / Find option it will only pick up on Name, not NameID. Does NameID always stay the same? Am I "safer" using NameID and Name in terms of the shape references never changing if someone adds additional shapes etc?
NameID returns a unique name for the shape within the page.
The differences in NameID and Name can be seen in the example. Shown below are the NameID and Name for the same 6 shapes.
Three shapes are drawn, the other three are derived from the Rectangle master shape.
NameID Name
Sheet.3 Sheet.3
Sheet.5 Rectangle
Sheet.6 Rectangle.6
Sheet.7 Rectangle.7
Sheet.8 Sheet.8
Sheet.9 Sheet.9
In the following example, I have removed several shapes and added new ones.
Sheet.6 Rectangle.6
Sheet.7 Rectangle.7
Sheet.8 Sheet.8
Sheet.9 Sheet.9
Sheet.10 Rectangle.10
Sheet.11 Rectangle.11
Sheet.12 Rectangle.12
Sheet.13 Ellipse
Sheet.14 Ellipse.14
Croc
Am I able to save the ShapeKey text alongside the name reference in the Collection and then search on the ShapeKey text in the "doing" part of the code? I ask as at the moment the code at the moment has to loop through the collections 300 times as it needs to find all items with 1 in the ShapeKey and move them to the back, then do the same with all items with 2 in etc:
For N = 300 To 1 Step -1
For Each itm In c
If ActivePage.Shapes(itm).CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = ActivePage.Shapes(itm).Cells("Prop.ShapeKey").ResultStr("")
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
ActiveWindow.Select ActivePage.Shapes(itm), visSelect
Debug.Print "added " & ActivePage.Shapes(itm).Name & " to selection"
End If
End If
Next itm
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
Next N
ActiveWindow.DeselectAll
This is understandably taking some time. I assume it would be quicker if it could go straight to select item 1- and then 1--P nd then 1--B etc move them to the back and then select 2-, 2--P etc...
I will try to suggest several possible solutions ...
1. When creating a collection, you can combine the text NameID & <separator> & ShapeKey. And when selecting elements, separate them with the "Split" function.
2. You can collect all shape names with ShapeKey = 1 -... into one collection.
To another collection - with ShapeKey = 2 -...
etc.
Then collect all these collections into a collection of a higher level. Since you can put not only strings into a collection, but also any objects, including collections.
3. If the ShapeKey is unique, then you can use the key argument of the Collection.Add(item, key, before, after) method
In this case, when selecting from a collection, you need to use not a number, but a key value.
Instead of
For Each itm In c
ActivePage.Shapes (itm)
or ActivePage.Shapes (c (i))
Will
ActivePage.Shapes (c("1-"))
ActivePage.Shapes (c("1-P"))
...
Perhaps it would be better to use method 1 in Sub RefreshData1(), and create a collection with a key in Sub CollectionFromData1() (method 3). To choose a solution, you need to know the features of your document: is the ShapeKey unique?, are there gaps in the numbering?, etc.
ShapeKey is unique. There are no gaps in the ordering 1-300 for all the various 1-, 1--P, 1--B etc (unless the user has accidentally deleted a shape). There are other Shapekey sets with other naming conventions
I have been running a timing comparison of the two code sets and in a very counterintuitive way, the original code which cycles through everything is faster than the one using a collection!
Original Code: 79s (7.71, 65.5, 107.2, 75.86s)
collection code: 144s (159.87, 143.37, 118.3, 154.23s)
For Reference, the original code is:
Sub ReOrder_including_within_layer()
Dim shp As Visio.Shape
Dim ShapeKey As String
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Application.ScreenUpdating = False
Application.DeferRecalc = True
ActiveWindow.DeselectAll
For N = 300 To 1 Step -1
For Each shp In ActivePage.Shapes
If shp.CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
ActiveWindow.Select shp, visSelect
End If
End If
Next shp
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
Next N
ActiveWindow.DeselectAll
'Call ReOrder_Layers
Finalise:
ActiveWindow.DeselectAll
Application.ScreenUpdating = True
Application.DeferRecalc = False
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
And the collection code is:
Public Sub WorkOperation() 'Executed multiple times
Call CollectionFromData1
' For Each itm In c 'NameId of target shapes only
' Debug.Print ActivePage.Shapes(itm).NameID & ": " & ActivePage.Shapes(itm).Name
' Next
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim ShapeKey As String
Application.ScreenUpdating = False
Application.DeferRecalc = True
ActiveWindow.DeselectAll
For N = 300 To 1 Step -1
For Each itm In c
If ActivePage.Shapes(itm).CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = ActivePage.Shapes(itm).Cells("Prop.ShapeKey").ResultStr("")
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Or ShapeKey = "BL_link-" & N Then
ActiveWindow.Select ActivePage.Shapes(itm), visSelect
'Debug.Print "added " & ActivePage.Shapes(itm).Name & " to selection"
End If
End If
Next itm
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
Next N
ActiveWindow.DeselectAll
'Call ReOrder_Layers
Finalise:
ActiveWindow.DeselectAll
Application.ScreenUpdating = True
Application.DeferRecalc = False
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
miless2111s, I would like to look at your document to try to choose the optimal algorithm for performing the operation. The algorithm can be highly dependent on the specifics of the document.
If the document does not contain classified information, send it to me at gcroc@yandex.ru
If the original document contains confidential information, then perhaps you can make the most similar analogue that I could use for testing.
I'm wondering if the order of the FOR loops were reversed if that might improve the speed. Presently you have the "PAGE" loop iinide the "N" loop. Try making the PAGE loop the outer loop and the N loop the inner. It might be that calling each page is slower than looping thru the variable N.
Just a thought.
Quote from: wapperdude on January 11, 2022, 04:54:26 PM
I'm wondering if the order of the FOR loops were reversed if that might improve the speed. Presently you have the "PAGE" loop iinide the "N" loop. Try making the PAGE loop the outer loop and the N loop the inner. It might be that calling each page is slower than looping thru the variable N.
Just a thought.
I am struggling with the reversal of logic... At the moment the code sets the number to look for (say 10) and looks at all shapes, if it finds a matching "10" it selects it and then when all shapes have been inspected sends all the "10" items to the back. Then it starts again for "9". How would this work for looking at each shape only once? Not saying that you're wrong only that my brain hasn't got to where you are :)
Let me say it..."My brain was wrong." My excuse...hadn't had morning coffeeeeeeee yet. Looking back at what I said, makes no sense. Sorry.
See how this macro will work for you.
Macro Sub WorkOperation_test2() works in one pass. Saving in the Data1 field is not used. Collections are not used.
The data is accumulated in one pass in the Arr(300) array, then the shapes are "SendToBack" for each row of the array.
This should work quickly.
Public Sub WorkOperation_test2()
Dim Arr(300)
For i = LBound(Arr) To UBound(Arr)
Arr(i) = ""
Next
Dim ShapeKey As String
For Each shp In ActivePage.Shapes
If shp.CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
arrN = Split(ShapeKey, "-")
If UBound(arrN) = 1 Then
If IsNumeric(arrN(0)) Then
If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then ' "1-"
N = arrN(0)
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
If IsNumeric(arrN(1)) Then
If CInt(arrN(1)) > 0 And CInt(arrN(1)) < 301 Then ' "BL_link-1"
N = arrN(1)
If ShapeKey = "BL_link-" & N Then
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
End If
If UBound(arrN) = 2 Then ' "1--p", "1--b", "1--R"
If IsNumeric(arrN(0)) Then
If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then
N = arrN(0)
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
End If
End If
Next
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Application.ScreenUpdating = False
Application.DeferRecalc = True
ActiveWindow.DeselectAll
For i = UBound(Arr) To 1 Step -1
arrN = Split(Arr(i), ";")
For j = LBound(arrN) To UBound(arrN) - 1
ActiveWindow.Select ActivePage.Shapes(arrN(j)), visSelect
Next
If ActiveWindow.Selection.Count <> 0 Then
ActiveWindow.Selection.SendToBack
ActiveWindow.DeselectAll
End If
Next
ActiveWindow.DeselectAll
'Call ReOrder_Layers
Finalise:
ActiveWindow.DeselectAll
Application.ScreenUpdating = True
Application.DeferRecalc = False
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Quote from: wapperdude on January 11, 2022, 06:16:42 PM
Let me say it..."My brain was wrong." My excuse...hadn't had morning coffeeeeeeee yet. Looking back at what I said, makes no sense. Sorry.
phew, for once it wasn't me :)
As an FYI, prior to Croc's most recent development, in your code, you step N from max value to min stepping -1. Since nothing is being deleted, there is no indexing ambiguity and stepping N from 1 to max value is permissible. Turns out, stepping down in value actually takes longer than the normal stepping up in value.
Don't know how much this will save in time. Nice of Croc to include a "built-in" elapsed time display.
Quote from: wapperdude on January 11, 2022, 09:40:15 PM
As an FYI, prior to Croc's most recent development, in your code, you step N from max value to min stepping -1. Since nothing is being deleted, there is no indexing ambiguity and stepping N from 1 to max value is permissible. Turns out, stepping down in value actually takes longer than the normal stepping up in value.
Don't know how much this will save in time. Nice of Croc to include a "built-in" elapsed time display.
The reason that I step down is I want items with a higher reference to be placed over the top of those with a lower reference. I don't want to use "move to front" as if the user has placed anything non-original in the summary then my re-ordering macro can not hide it.
Quote from: Croc on January 11, 2022, 06:56:59 PM
See how this macro will work for you.
Macro Sub WorkOperation_test2() works in one pass. Saving in the Data1 field is not used. Collections are not used.
The data is accumulated in one pass in the Arr(300) array, then the shapes are "SendToBack" for each row of the array.
This should work quickly.
You are absolutely correct, this does run * a lot* faster :) 16 seconds against the PB for 58 seconds for my original code :) Excellent. A lovely use of an array, populating as you go through the shapes, genius. There's a lot to unpack and I have to go now, but I will get back to it tomorrow and try to ask some intelligent questions to better understand what it is doing at each stage so I can continue my learning curve.
Thank you very much for the time and effort you've given me on this :)
Croc, sorry for the delay in getting back to you, the week went nuts :)
Can I check my understanding of what the code is doing to make sure I am learning? I have some questions which I show in italics and I will pull out at the bottom for ease.
For Each shp In ActivePage.Shapes
If shp.CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
arrN = Split(ShapeKey, "-") ' splits ShapeKey into parts so it could be (1) or (1,,p) or (BL_link, 1)
If UBound(arrN) = 1 Then 'counts how many items are in the array, if 1 (i.e. the Shapekey was 1 or 100 or Fred) then it continues with the next code, if not it jumps a [b]A[/b]
If IsNumeric(arrN(0)) Then 'checks that the contents of the array is numeric (i,e, ignores Fred)
If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then ' "1-" 'checks that the number is between 1 and 300
N = arrN(0) 'sets the location in arrN to the number shown in ShapeKey (1 or 100)
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then [i]'Why is it checking for these? Don't the preceding steps ensure that it will be 1, 2,50 or 300 etc)?[/i]
Arr(N) = Arr(N) & shp.NameID & ";" 'updates arr(n) with the ShapeKey reference at the appropriate place in the array.
End If
End If
End If
If IsNumeric(arrN(1)) Then 'checks the second position in the array is numeric (fred-1 or BL_link-1) [i] How has this been triggered given it is in the uBound(arrN) = 1 section and BL_link-1 would have split into BL_Link and 1 which would count as 2?[/i]
If CInt(arrN(1)) > 0 And CInt(arrN(1)) < 301 Then ' "BL_link-1"
N = arrN(1)
If ShapeKey = "BL_link-" & N Then ' ignores "fred-1" and only processes if ShapeKey = BL_link-1
Arr(N) = Arr(N) & shp.NameID & ";" [i]'will this not overwrite Arr(1) = "1-" with "BL_Link-1"?[/i]
End If
End If
End If
End If
If UBound(arrN) = 2 Then ' "1--p", "1--b", "1--R" [b]A[/b]
If IsNumeric(arrN(0)) Then
If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then
N = arrN(0)
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R" Then [i]'is Shapekey = N redundant here?[/i]
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
End If
End If
Next
Questions pulled out:
- When the 1st time that ShapeKey = N & "-" etc appears is this redundant given what the previous steps are checking that there is only a number in ShapeKey?
- SOLVED: How is "If IsNumeric(arrN(1)) Then " triggered when it is within the IF loop that checks that ShapeKey only contains something like 1- or 200-. I hadn't appreciated that UBOUND returns the index of the last item rather than the number of items in the array. I think this is because I normally use arrays starting at 1 rather than 0.
- SOLVED: Why doesn't Arr(N) = Arr(N) & shp.NameID & ";" overwrite the previous entry? Or is this adding onto the listing in that location of the array? so we have 1-;BL_Link-1 etc? - this is exactly what is happening and I learnt yet another thing today :)
- Is the test "ShapeKey = N" redundent the second time that the tests "If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R"" appears? or is this needed for some reason?
This is very a very clever use of an array and I am working my way towards understanding exactly how it all works :)
First we create an array of 300 empty elements.
Then, in a loop, we look through the shapes and fill in the elements of the array.
But the shapes come in random order. To determine the position in the array, we must select a number from the cell "Prop.ShapeKey" - N. Thus, at the end we will get an array with gaps - not all elements will be filled.
In addition, several shape names need to be packed into one array row. In this case, the newly found value and the separator ";" are added to the end of the existing string. This is the operation Arr(N) = Arr(N) & shp.NameID & ";". As a result, the row will contain all the names of shapes related to the same number N.
The algorithm is imperfect, since the very last character ";" line will be redundant. But I remember it and take it into account in the statement "For j = LBound(arrN) To UBound(arrN)-1". That is why UBound(arrN)-1 is here.
Now about the IsNumeric function.
We know that N can occur in different places in the "Prop.ShapeKey" field - at the beginning or at the end. How to choose this number?
We can go through all the characters sequentially, find one or two "-" separators, then check which part is a number.
Or We can split the ShapeKey string with the "Split" function into several parts. There will be 2 or 3 such parts. I chose this method. Moreover, I did not optimize the algorithm, I just wanted to check whether it is suitable in principle.
The number selection algorithm consists of two successive checks, the first check consisting of two parts:
1. If UBound(arrN) = 1. The array contains 2 elements. This is for the values "N-" and "BL_link-N". "N-" = N, <empty>. "BL_link-N" = BL_link, N.
1a. If IsNumeric(arrN(0)). The first element is a number. So the format is "N-".
1b. If IsNumeric(arrN(1)). The second element is a number. So the format is "BL_link-N".
2. If UBound(arrN) = 2. The array contains 3 elements. This is for the values "N--p", "N--b", etc. "N--p" = N, <empty>, p.
There is also a check "If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--b" Or ShapeKey = N & "--R"
This check came about because I don't know the exact requirements for the algorithm.
It assumes that "N--p","N--b", "N--R" are valid values, and "N--f", "N--g"... is not in the list of valid values.
Hi Croc
Thanks for the tutorial on your excellent "massive array" code :) I think I understand most if not all of it now.
I have run into an issue I am struggling with. During the execution of the code I used debug.print to see what was going on however it ran out of space so I outputted the contents of arr() to a text file using the code below and it showed that I am either missing some items or have duplicates. This isn't in itself an issue as I can fix this.
Public Sub Cat_1_to_300_with_issues()
Dim Arr(300)
For i = LBound(Arr) To UBound(Arr)
Arr(i) = ""
Next
Dim ShapeKey As String
For Each shp In ActivePage.Shapes
If shp.CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
arrN = Split(ShapeKey, "-")
If UBound(arrN) = 1 Then
If IsNumeric(arrN(0)) Then
If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then ' "1-"
N = arrN(0)
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R" Then
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
If IsNumeric(arrN(1)) Then
If CInt(arrN(1)) > 0 And CInt(arrN(1)) < 301 Then ' "BL_link-1"
N = arrN(1)
If ShapeKey = "BL_link-" & N Then
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
End If
If UBound(arrN) = 2 Then ' "1--p", "1--b", "1--R"
If IsNumeric(arrN(0)) Then
If CInt(arrN(0)) > 0 And CInt(arrN(0)) < 301 Then
N = arrN(0)
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R" Then
Arr(N) = Arr(N) & shp.NameID & ";"
End If
End If
End If
End If
End If
Next
' Dim StartTime As Double
' Dim SecondsElapsed As Double
' StartTime = Timer
Application.ScreenUpdating = False
Application.DeferRecalc = True
ActiveWindow.DeselectAll
'debugprint items with missing or to many entries
For S = 1 To 300
arrN = Split(Arr(S), ";")
If UBound(arrN) <> 4 Then
For j = LBound(arrN) To UBound(arrN) - 1
op = ActivePage.Shapes(arrN(j)).Cells("Prop.ShapeKey").ResultStr("") & "; " & op
Next j
Debug.Print "Ref: " & S & ": " & op
op = ""
End If
Next S
'print out all shapes to a text file to allow me to see what is missing / repeated in the array
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Fileout As Object
Set Fileout = fso.CreateTextFile("C:\SummaryPro\Temp working area - always transfer back to one drive at COP\output.txt", True, True)
For i = 1 To UBound(Arr)
arrN = Split(Arr(i), ";")
For j = LBound(arrN) To UBound(arrN) - 1
op = ActivePage.Shapes(arrN(j)).Cells("Prop.ShapeKey").ResultStr("") & "; " & op
Next j
Fileout.write op
Fileout.write Chr(13) & Chr(10)
op = ""
Next i
Fileout.Close
Finalise:
ActiveWindow.DeselectAll
Application.ScreenUpdating = True
Application.DeferRecalc = False
SecondsElapsed = Round(Timer - StartTime, 2)
'MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
MsgBox "all done"
End Sub
The issue is that when I use a simpler code to output everything on the page it shows that the "missing" items (for instance 201--P to 300-P, 15--P, 57--Pand 115--P) are actually present on the page but they don't seem to have been collected by the output code.
Sub Cat_all_shapes()
Application.ScreenUpdating = False
Application.DeferRecalc = True
ActiveWindow.DeselectAll
'setup print out to text file
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Fileout As Object
Set Fileout = fso.CreateTextFile("C:\SummaryPro\Temp working area - always transfer back to one drive at COP\output_all_shapes.txt", True, True)
'identify shapes
For Each shp In ActivePage.Shapes
If shp.CellExistsU("Prop.ShapeKey", 0) Then
ShapeKey = shp.Cells("Prop.ShapeKey").ResultStr("")
Fileout.write ShapeKey
Fileout.write Chr(13) & Chr(10)
End If
Next shp
Finalise:
ActiveWindow.DeselectAll
Application.ScreenUpdating = True
Application.DeferRecalc = False
MsgBox "all shapes printed out"
End Sub
Have I done something silly in my "print out" code showing what arr(N) is containing? Or is there something odd about the items which are missing? They tend to appear fairly far down the "all shapes" output - starting at item 1772 and running till 1877
You asked a question about the condition
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R"
This condition considers ShapeKey = 201--p to be correct. But 201--P is not the same as 201--p. Therefore, 201--P is considered invalid and discarded.
If all combinations of N & <letter> are correct, then check
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R"
needs to be removed from the code.
If you only want to add "P", then you need to add one more Or condition. That is, use
If ShapeKey = N & "-" Or ShapeKey = N & "--p" Or ShapeKey = N & "--P" Or ShapeKey = N & "--B" Or ShapeKey = N & "--R"
Oh for goodness sake! how could I have missed the capital!? Thank you for that.