Excel VBA: How to obtain a reference to a Shape from the ChartObject - excel

I am trying to obtain a reference to a Shape in a Worksheet, corresponding to a ChartObject. I found no certain way of doing this. The only approximation, by trial-and-error and simply tested in a few cases, is assuming that the ZOrder of a ChartObject is the same as the Index of the corresponding Shape:
Function chobj2shape(ByRef cho As ChartObject) As Shape
' It appears that the ZOrder of a ChartObject is the same as the Index of
' the corresponding Shape, which in turn appears to be the same as its ZOrderPosition
Dim zo As Long
Dim ws As Worksheet
Dim shc As Shapes
Dim sh As Shape
zo = cho.ZOrder
Set ws = cho.Parent
Set shc = ws.Shapes
Set sh = shc.Item(zo)
Set chobj2shape = sh
'Set sh = Nothing
End Function
(a slight excess of defined variables is used for debugging purposes).
Is there any more certain way of doing this?
Any identifier used for picking the correct Shape should be unique. The name is not necessarily unique (see https://stackoverflow.com/questions/19153331/duplicated-excel-chart-has-the-same-name-name-as-the-original-instead-of-increm), so it is not guaranteed to work. The Index/ZOrderPosition is just a guess, at least satisfying the requirement of uniqueness.
Edit: see answer by #Andres in Excel VBA: Index = ZOrderPosition in a Shapes collection?. It is clear that the ZOrder of a ChartObject is not equal to the Index of either the ChartObject or the corresponding Shape (and I have verified this).
But it appears that ZOrder is equal to ZOrderPosition of the corresponding Shape. This was verified with dump_chartobjects:
Sub dump_chartobjects()
' Dump information on all ChartObjects in a Worksheet.
Dim coc As ChartObjects
Set coc = ActiveSheet.ChartObjects
Dim cho As ChartObject
Dim ich As Long
For ich = 1 To coc.Count
Dim msg As String
Set cho = coc(ich)
With cho
msg = "ChartObject '" & .name & "'" _
& ", type name: " & TypeName(cho) & ", at: " & .TopLeftCell.Address _
& ", index: " & ich & ", .Index: " & .Index _
& ", ZOrder: " & .ZOrder
'& ", hyperlink: " & .Hyperlink
End With
Debug.Print msg
Dim ish As Long
ish = choidx2shpidx(ich, coc.Parent)
Next ich
End Sub
Function choidx2shpidx(coidx As Long, ws As Worksheet) As Long
Dim cozo As Long
Dim coc As ChartObjects
Dim co As ChartObject
Set coc = ws.ChartObjects
Set co = coc(coidx)
cozo = co.ZOrder
choidx2shpidx = zo2idx_shp(cozo, ws)
Dim con As String, shn As String
Dim sh As Shape
Set sh = ws.Shapes(choidx2shpidx)
con = co.name
shn = sh.name
Dim cox As Double, coy As Double
Dim cow As Double, coh As Double
Dim shx As Double, shy As Double
Dim shw As Double, shh As Double
cox = co.Left
coy = co.top
cow = co.Width
coh = co.Height
shx = sh.Left
shy = sh.top
shw = sh.Width
shh = sh.Height
If ((con <> shn) Or (cox <> shx) Or (coy <> shy) Or (cow <> shw) Or (coh <> shh)) Then
Dim msg As String
msg = "ChartObject: '" & con & "', Shape: '" & shn & "'"
'Debug.Print msg
MsgBox msg
choidx2shpidx = -1
End If
End Function
Function zo2idx_shp(zo As Long, ws As Worksheet) As Long
Dim ish As Long
Dim shc As Shapes
Dim sh As Shape
Set shc = ws.Shapes
For ish = 1 To shc.Count
Set sh = shc(ish)
If (sh.ZOrderPosition = zo) Then
zo2idx_shp = ish
Exit Function
End If
Next ish
zo2idx_shp = -1
End Function

After losing hours in a similar issue, I found a couple of concepts related to referencing shapes in excel, but none satisfies me 100%. For accessing a shape you have 4 pure methods:
Shape.Name : Is FAST, but NOT RELIABLE. The name of the shape could be used to get a reference of a shape but provided you don't have duplicated names. Code: ActiveSheet.Shapes("Shape1")
Shape.ZOrderPosition : Very FAST, but NOT RELIABLE. The ZOrder of the shape could be used to get a reference of a shape, because is the same as the index of the shape in the shapes collection. But provided you don't have group of shapes that breaks previous rule (See: https://stackoverflow.com/a/19163848/2843348). Code: ActiveSheet.Shapes(ZOrderFromOneShape)
Set shpRef=Shape: FAST, RELIABLE, but NOT PERSISTENT. I try to use this always I can, specially when I create a new shape. Moreover, if I have to iterate on the new shapes later one I try to keep the object reference inside a collection. However not Persistent, that means if you stop and run you VBA code again to will loose all the references and collection. Code: Set shp = NewShape, or you can add it to a collection: coll.add NewShape for loop it later on.
Shape.ID : RELIABLE, PERSISTENT, but not directly supported! The ID of the shape is very reliable (don't change and cannot be duplicates IDs in a Sheet). However, there is no direct VBA function to get a shape back knowing its ID. The only way is to loop thorough all shapes until the ID match the ID you was looking for, but this can be very SLOW!.
Code:
Function FindShapeByID(ws as excel.worksheet, ID as long) as Excel.Shape
dim i as long
set FindShapeByID = nothing 'Not found...
for i = 1 to ws.shapes.count
if ws.shapes(i).ID = ID then
set FindShapeByID = ws.shapes(i) 'Return the shape object
exit function
end if
next i
End Function
Note 1: If you want to access this function several times, you can improve it by using a cache of Shape IDs. That way you will make the loop only one time.
Note 2: If you move a shape from one sheet to other, the ID of the shape will change!
By mixing and using above knowledge, I have concluded in two main approaches:
FIRST APPROACH
FASTEST BUT VOLATILE: (same as point#3) Try to keep the reference in a object as longer you can. When I have to iterate trough a bunch of shapes later on, I save the references inside a collection and I avoid to use other secondary reference like the name, ZOrder or ID.
For example:
dim col as new Collection
dim shp as Excel.Shape
'' <- Insert the code here, where you create your shape or chart
col.add shp1
'' <- Make other stuffs
for each shp in col
'' <- make something with the shape in this loop!
next shp
The problem of course is that the collection and reference are not permanent. You will loose them when you stop and restart the vba code!
SECOND APPROACH
PERSISTENT: My solution is to save the name and the ID of the shape for later reference. Why? Having the name I can access the shape very fast most of the time. Just in case I found a duplicated name I make the slow loop searching the ID. How can I know if there is a name duplicated? Very simple, just check the ID of the first name search, and if they don't match you have to suppose is duplicated.
Here the code:
Function findShapeByNameAndID(ws As Excel.Worksheet, name As String, ID As Long) As Shape
Dim sh As Excel.Shape
Set findShapeByNameAndID = Nothing 'Means not found
On Error GoTo fastexit
Set sh = ws.Shapes(name)
'Now check if the ID matches
If sh.ID = ID Then
'Found! This should be the usual case!
Set findShapeByNameAndID = sh
Else
'Ups, not the right shape. We ha to make a loop!
Dim i As Long
For i = 1 To ws.Shapes.Count
If ws.Shapes(i).ID = ID Then
'Found! This should be the usual case!
Set findShapeByNameAndID = ws.Shapes(i)
End If
Next i
End If
fastexit:
Set sh = Nothing
End Function
Hope this helps you!
Note 1: Is you want to search shapes that maybe inside groups, then the function is more complicated.
Note 2: The ZOrder looks nice, but cannot find it useful. When I tried to take advantage of it, there was always a missing part...

#TimWilliams is almost right (in his comment). However, there are some situation where Tim's idea could get confusing results.
I think the following code will be more appropriate and correct.
Sub qTest()
Dim cho As ChartObject
Set cho = ActiveSheet.ChartObjects(1)
Dim SH As Shape
Set SH = cho.ShapeRange.Item(1)
SH.Select 'here Shape will be selected..
Debug.Print TypeName(SH) '...which we can check here
End Sub

Related

Fill shape data field from external data

I'm trying to link shape data field from external data like excel.
As #JohnGoldsmith suggested I used DropLinked but "I'm getting object name not found" error.
My main agenda is drop multiple shapes on drawing with shape data field "Name", then fill all the shape data field using external data in order. I also used spatial search for dropping shapes on drawing(Thanks to #Surrogate). By the way I'm using Visio Professional 2019.
It's often a good plan to separate chained members so you can identify whether (as #Paul points out) you're having a problem getting to the stencil or the master.
Following is a modified example of link shapes to data. I've ditched all of the spatial search stuff as I think that's a separate issue. If you still have trouble with that I would ask another question and narrow your sample code to not include the data linking part - ie just drop shapes and try and change their position. Bear in mind there's also Page.Layout and Selection.Layout
I think you've got the adding the DataRecordsets in the other linked question, so this example makes the following assumptions:
You have a drawing document open
You have the "Basic Shapes" stencil open (note my version is metric "_M")
You have a DataRecordset applied to the document named "AllNames"
The above record set has a column named "Name" that contains the data you want to link
Public Sub ModifiedDropLinked_Example()
Const RECORDSET_NAME = "AllNames"
Const COL_NAME = "Name"
Const STENCIL_NAME = "BASIC_M.vssx"
Const MASTER_NAME = "Rectangle"
Dim vDoc As Visio.Document
Set vDoc = Application.ActiveDocument
Dim vPag As Visio.Page
Set vPag = Application.ActivePage
Dim vShp As Visio.Shape
Dim vMst As Visio.Master
Dim x As Double
Dim y As Double
Dim xOffset As Double
Dim dataRowIDs() As Long
Dim row As Long
Dim col As Long
Dim rowData As Variant
Dim recordset As Visio.DataRecordset
Dim recordsetCount As Integer
For Each recordset In vDoc.DataRecordsets
If recordset.Name = RECORDSET_NAME Then
dataRowIDs = recordset.GetDataRowIDs("")
xOffset = 2
x = 0
y = 2
Dim vStencil As Visio.Document
Set vStencil = TryFindDocument(STENCIL_NAME)
If Not vStencil Is Nothing Then
Set vMst = TryFindMaster(vStencil, MASTER_NAME)
If Not vMst Is Nothing Then
For row = LBound(dataRowIDs) + 1 To UBound(dataRowIDs) + 1
rowData = recordset.GetRowData(row)
For col = LBound(rowData) To UBound(rowData)
Set vShp = vPag.DropLinked(vMst, x + (xOffset * row), y, recordset.ID, row, False)
Debug.Print "Linked shape ID " & vShp.ID & " to row " & row & " (" & rowData(col) & ")"
Next col
Next row
Else
Debug.Print "Unable to find master '" & MASTER_NAME & "'"
End If
Else
Debug.Print "Unable to find stencil '" & STENCIL_NAME & "'"
End If
Else
Debug.Print "Unable to find DataRecordset '" & RECORDSET_NAME & "'"
End If
Next
End Sub
Private Function TryFindDocument(docName As String) As Visio.Document
Dim vDoc As Visio.Document
For Each vDoc In Application.Documents
If StrComp(vDoc.Name, docName, vbTextCompare) = 0 Then
Set TryFindDocument = vDoc
Exit Function
End If
Next
Set TryFindDocument = Nothing
End Function
Private Function TryFindMaster(ByRef vDoc As Visio.Document, mstNameU As String) As Visio.Master
Dim vMst As Visio.Master
For Each vMst In vDoc.Masters
If StrComp(vMst.NameU, mstNameU, vbTextCompare) = 0 Then
Set TryFindMaster = vMst
Exit Function
End If
Next
Set TryFindMaster = Nothing
End Function
The above code drops six shapes onto the page and adds a Shape Data row (Prop._VisDM_Name) with the corresponding data value. If you want the name text to appear in the shape then you would normally modify the master with an inserted field in the shape's text. (If you get stuck with this part then ask another question.)
One last point is that this example loops through the DataRecordset rows dropping a shape for each one, but there is also a Page.DropManyLinkedU method that allows you to this en masse.

Grouping an Array of Shapes

When an array of Shapes is given to a subroutine By Reference, how can these Shapes be grouped, WITHOUT referring to them by their .name strings ?
The code below does not work:
Sub GroupShapes(ByRef ShapeArray() As Shape)
Dim i As Long
Dim IDs() As Variant
ReDim IDs(LBound(ShapeArray) To UBound(ShapeArray))
For i = LBound(ShapeArray) To UBound(ShapeArray)
IDs(i) = ShapeArray(i).ID 'If .ID is changed into .Name then the objects become grouped Later, but they are being referred to by their name strings
Next i
ActiveSheet.Shapes.Range(IDs).Group
End Sub
I can make the code above work, just by changing .ID to .Name, but that is referring to the shapes by their .name strings which is exactly what I am trying to avoid.
As has been noted, you can create a ShapeRange by index. The difficulty is in finding the index of your shape, which isn't the same as the ID property. Additionally, your shape may already be grouped, so it won't necessarily exist at Worksheet.Shapes level
It's possible to have nested shape groups, but I believe these have to be nested from bottom-level up. In other words, I think if you try to sub-group and already grouped shape, an error will be thrown.
I may be missing something obvious, but that suggests we can group the array by finding the Worksheet.Shapes level index of a shape that either is or contains our target shape. And the index could be found by iterating those top-level shapes until the unique ID property matches. It would then be possible to create a ShapeRange on the resulting indexes.
I wonder if something like this would work:
Private Function GroupShapes(ByRef shapeArray() As Shape) As Shape
Dim i As Long, n As Long
Dim ws As Worksheet
Dim sh As Shape
Dim obj As Object
Dim idList As Collection
Dim id As Variant
Dim idArray() As Long
'Create the list of ids for sheet level shapes.
Set idList = New Collection
For i = LBound(shapeArray) To UBound(shapeArray)
Set sh = shapeArray(i)
Do While sh.Child
Set sh = sh.ParentGroup
Loop
On Error Resume Next
idList.Add sh.id, CStr(sh.id)
On Error GoTo 0
Next
If idList.Count <= 1 Then Exit Function
'Define the sheet parent.
Set obj = shapeArray(LBound(shapeArray)).Parent
Do Until TypeOf obj Is Worksheet
Set obj = obj.Parent
Loop
Set ws = obj
'Find the indexes of the shape ids.
ReDim idArray(idList.Count - 1)
n = 0
For Each id In idList
i = 1
For Each sh In ws.Shapes
If id = sh.id Then
idArray(n) = i
Exit For
End If
i = i + 1
Next
n = n + 1
Next
'Group by index.
Set GroupShapes = ws.Shapes.Range(idArray).Group
End Function
The following test seemed to work for me:
Public Sub RunMe()
Dim shapeArray(0 To 3) As Shape
Dim g As Shape
'Create a sample array.
'Note some of these shapes are already grouped so
'wouldnt appear at Sheet.Shapes level.
Set shapeArray(0) = Sheet1.Shapes("Rectangle 1")
Set shapeArray(1) = Sheet1.Shapes("Isosceles Triangle 2")
Set shapeArray(2) = Sheet1.Shapes("Arrow: Right 4")
Set shapeArray(3) = Sheet1.Shapes("Oval 7")
'Group the array.
Set g = GroupShapes(shapeArray)
End Sub

How to connect visio shapes on page by passing the name of the shape to connect to from a variable?

I am trying to connect the visio shapes in my drawing. I am using autoconnect. I have a loop that goes thru all the visio shapes in my drawing. It goes thru the values in my range and compares them to the shape name, if the shape name matches then it should connect to the shape who has the name stored in the offset (0, 2) of my range variable but I’m having problems passing the variable to the script. If I do a debug print for the variable that stores the shape names to connect to then it prints to screen the names of the shapes that the current shape in the loop needs to connect to. So it has the correct data.
Here is some of the code.
Dim conns As Range
Dim connto_str As String
Dim ew As Excel.Workbook
Set ew = wbkInst.ActiveWorkbook
Dim conns As Range
Dim cel As Range
Dim ws As Worksheet
For Each ws In ew.Sheets
Set conns = ws.Range("j3:j22")
For Each cel In conns
With cel
c = cel.Value
connto_str = cel.Offset(0, 2).Value
End With
For Each node In ActivePage.Shapes
If node.Name = c Then
node.AutoConnect connto_str, visAutoConnectDirNone
'Debug.Print connto_str
Else
End If
Next node
Next cel
Next ws
I need to be able to pass the content of the variable this statement.
node.AutoConnect connto_str, visAutoConnectDirNone
Thanks
connto_str needs to be an Object of Type Shape, not just the name of a Shape.
If you know on which page the shape is on you can use page.Shapes("ShapeName") to get a reference to the shape.
Source :
Microsoft Docs Visio.Shape.AutoConnect Method
Microsoft Docs Shapes.Item Property
Dim ew As Excel.Workbook
Set ew = wbkInst.ActiveWorkbook
Dim ws As Worksheet
For Each ws In ew.WorkSheets 'use .WorkSheets, to avoid selecting other Sheet-Types like diagrams
Dim conns As Range
Set conns = ws.Range("j3:j22")
Dim cel As Range
For Each cel In conns.cells
Dim c as String
c = cel.Value
Dim connto_str As String
connto_str = cel.Offset(0, 2).Value
Dim conno_shp as Shape
Set conno_shp = activePage.Shapes(conno_shp)
Dim node as Shape
Set node = ActivePage.Shapes(c)
node.AutoConnect connto_shp, visAutoConnectDirNone
Next cel
Next ws
You also forgot to declare/dim node.
I cleaned up your code a bit, although it is still quite fragile, since you assume so know the name of the Shape, which actually may change as you drop it.
Your Variable-Names are a bit difficult to understand, you probably should change them to something more readable, your successor will thank you. Use names that are self-explanatory.
Why not give each shape you drop an entry into the ShapeSheet under the User-Section, something like User.NetworkDiagrammName.

Set a range with a string/cell contents

I'm writing some code for a client which pulls data from many differently laid out files. I wanted to write something which was quite flexible for him in the future.
Therefore, he will be able to write for example y.offset(0,1) in a cell depending where in regards to the variable y the data will be.
The reason I haven't just made the the variable 1 is because it, and therefore the cell, may or may not include multiple & "blah blah"
Basically, I'm wondering if it's possible to write parts of code in a cell then pull them up and incorporate them into code.
For instance:
Dim y as range
Dim x as range
Dim c as string
Set Y = Sheet1.range("G4")
c = sheet1.range("A1") [which contains the words y.offset(0,4)
Set x = c
This doesn't work, however I'm wondering if there's anything that can be done to get the same result.
Your need is kind of a recursive and dangerous one
then it deserves such a recursive and dangerous answer
you could use the VBA Project Object Model (see here for info) and act as follows:
Set your project to handle VBA Object Model
follow all the steps you can see in the Introduction of the above given link to cpearson website Add reference to your project
Disclaimer: please also read the CAUTION note in there
add "helper" module
add to your project a new Module and call it after "HelperModule" (you can call it as you like, but then be consistent with the chosen name)
then add this code into this new module
Function GetRange(refRng As Range) As Range
Set GetRange = refRng
End Function
Function SetToCellContent(refRng As Range, cellContent As String) As Range
UpdateCodeModule cellContent
Set SetToCellContent = HelpModule.GetRange(refRng)
End Function
Sub UpdateCodeModule(cellContent As String)
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Set CodeMod = ActiveWorkbook.VBProject.VBComponents("HelperModule").CodeModule
LineNum = SearchCodeModuleLine(CodeMod, "Set GetRange")
CodeMod.ReplaceLine LineNum, " Set GetRange = " & cellContent
End Sub
Function SearchCodeModuleLine(CodeMod As VBIDE.CodeModule, FindWhat As String) As Long
Dim SL As Long ' start line
Dim SC As Long ' start column
Dim EL As Long ' end line
Dim EC As Long ' end column
Dim Found As Boolean
With CodeMod
SL = 1
EL = .CountOfLines
SC = 1
EC = 255
Found = .Find(Target:=FindWhat, StartLine:=SL, StartColumn:=SC, EndLine:=EL, EndColumn:=EC, wholeword:=True, MatchCase:=False, patternsearch:=False)
End With
SearchCodeModuleLine = SL
End Function
Add this code to your main code
Set x = SetToCellContent(y, c) '<--| call the function that will take care of updating code in 'GetRange()' function and returns a range relative to 'y' as per the "code" in 'c'

Run-time error '7': Out of memory

I'm trying to edit embedded charts in Word documents. My source code is below. It has worked a long time but not for the last two days. I get this error:
Run-time error '7': Out of memory
I have searched a lot , but I don't understand the problem. When I shutdown computer and after open it, then it works correctly, but after I get error again.
It gives error in this part:
'create range with Cell
Set oChart = oInShapes.Chart
oChart.ChartData.Activate ' ***Note: It gives error here***
'Set oWorkbook = oChart.ChartData.Workbook
Set oWorksheet = oChart.ChartData.Workbook.Worksheets("Tabelle1")
Set oRange = oWorksheet.Range(Cell)
Public Sub updatechart(Doc As word.Application, ChartName As String, ChartTitle As String, Cell As String, data As String)`
Dim oInShapes As word.InlineShape
Dim oChart As word.Chart
Dim oWorksheet As Excel.Worksheet
'Dim oWorkbook As Excel.Workbook
Dim columnArray() As String
Dim rowArray() As String
Dim oRange As Range
Dim i As Integer
Dim j As Integer
For Each oInShapes In Doc.ActiveDocument.InlineShapes
' Check Shape type and Chart Title
If oInShapes.HasChart Then
'create range with Cell
Set oChart = oInShapes.Chart
oChart.ChartData.Activate ' ***Note: It gives error here***
'Set oWorkbook = oChart.ChartData.Workbook
Set oWorksheet = oChart.ChartData.Workbook.Worksheets("Tabelle1")
Set oRange = oWorksheet.Range(Cell)
' Commet for debug
'oWorksheet.Range("B33") = (ChartTitle & 33)
' Split text
columnArray = Split(data, SeperateChar)
For i = LBound(columnArray) To UBound(columnArray)
rowArray = Split(Trim(columnArray(i)), " ")
' Set Title. For example; ChartTitle = "XY" ----- Table Titles ----> | XY1 | XY2 | XY2 | ....
' After Set Value | 0,33| 0,1 | 0,46| ....
oRange.Cells(1, i + 1) = ChartTitle & (i + 1)
For j = LBound(rowArray) To UBound(rowArray)
' Set Values
oRange.Cells(j + 2, i + 1) = CDbl(rowArray(j))
Next j
Next i
'oWorkbook.Close
oChart.Refresh
End If
Next
Set oInShapes = Nothing
Set oChart = Nothing
Set oWorksheet = Nothing
'Set oWorkbook = Nothing
Erase rowArray, columnArray
End Sub
This has happened to me before. I had the same solution, exit excel, free up some memory and try again - and it worked. You may have to shut down other programs while using this. Its literally what it says it is, lack of available memory.
Keep in mind that if you've run other macros that copy information to the clipboard, you will have less RAM freed up to run the macro.
Also, are you using 32 or 64 bit Excel - 64 will allow you to use more RAM.
I notice that you not set oRange to nothing when cleaning up your sub, could it be that this object is using a lot of memory which isn't being released when the sub ends?
I had a similar error and finally traced it down to the "For Each" statement. I think it has to do with the memory allocation for the Collection, Doc.ActiveDocument.InlineShapes in your example.
My bad code (PowerPoint to Excel):
For Each sh In InputBook.Sheets("Exec Sum").Shapes
sh.Visible = False
Next
Set sh = Nothing
My fixed code:
For i = 1 To InputBook.Sheets("Exec Sum").Shapes.Count
InputBook.Sheets("Exec Sum").Shapes(i).Visible = False
Next
Avoiding a reference to a collection solved my issue.
The frequent access to the worksheet can create problems with resource usage. The way to go about this is to fetch data in a single access point, like
Dim V as Variant
V = InputRange
' Now V becomes a m x n array of the cell values in InputRange
' you may manipulate and work with this data and fill all your results in
' OutputV(m,n) variant array
Dim OutputV() as Variant
ReDim OutputV(m,n)
oRange = OutputV
Usually speeds up the code by several hundred times depending on the size of the range and also uses far less resources.

Resources