So I've been working on trying to resize a Visio box in Visual Basic for a project in work, using some code that was given to me as I am very new to Visual Basic.
I have tried many methods without any result, and I am now working on using the Shape.Resize() method which works but then throws an error:
If ActiveCell.Offset(0, 2).Value = "D" Then
Dim sizer As Double
sizer# = 2
iData = iData + 1
Set shp = CreateVisioObject(AppVisio, "Box", 2.5, 7.25, ActiveCell.Offset(0, 1).Value, """AccentColor4""")
Set shp = shp.Resize(0, sizer, 65)
Set shp = shp.Resize(2, sizer, 65)
End If
On line 6, I get the error "Run-time error '13': Type mismatch", but the code still executes before throwing this error (ie; the width of the shape changes but the code stops at this line.) Here is the code for the CreateVisioObject:
Function CreateVisioObject(ByRef oVisio As Object, strType As String, posX As Double, posY As Double, strText As String, strColor As String) As Object
Set shp = oVisio.ActiveWindow.Page.Drop(oVisio.Documents.Item("BLOCK_U.VSS").Masters.ItemU(strType), posX, posY)
shp.CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "20 pt"
Set oCharacters = shp.Characters
oCharacters.Begin = 0
oCharacters.End = Len(oCharacters)
sChar = strText
oCharacters.Text = sChar
shp.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(THEMEVAL(" + strColor + "))"
shp.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEMEVAL(""FillColor""),THEMEVAL(""FillColor2""))))"
shp.CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
Set CreateVisioObject = shp
End Function
Here is the reference for the Shape.Resize() - https://msdn.microsoft.com/en-us/vba/visio-vba/articles/shape-resize-method-visio
Also, the code is using an Excel sheet to generate the Visio document.
Thank you for your help!
I didn't know about Shape.Resize Method before. When i want resize some shape i just change it Width and Height
shp.Cells("width") = 2
shp.Cells("height") = 2
Related
I'm programming a custom chart add-in for Word that should behave the same as add-ins I've already done for Excel and PowerPoint. The code is very similar in all three programs, but I'm getting a baffling error in Word that doesn't occur in the other 2 programs.
Excel (works just fine):
Sub AddTextboxToChart()
Dim oChart As Chart
Dim oChtShp As Shape
Dim oLegShp As Shape
sChtName = ActiveChart.Name
ChtShpName$ = Right(sChtName, Len(sChtName) - InStrRev(sChtName, " ", Len(ActiveSheet.Name) + 1))
Set oChtShp = ActiveSheet.Shapes(ChtShpName$)
Set oChart = oChtShp.Chart
Set oLegShp = oChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
oLegShp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End Sub
PowerPoint (also works fine):
Sub AddTextboxToChart()
Dim oChart As Chart
Dim oChtShp As Shape
Dim oLegShp As Shape
If ActiveWindow.Selection.ShapeRange(1).HasChart Then
Set oChtShp = ActiveWindow.Selection.ShapeRange(1)
Set oChart = oChtShp.Chart
Set oLegShp = oChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100)
oLegShp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End If
End Sub
Word (errors on "Set oLegShp" line):
Sub AddTextboxToChart()
Dim oChart As Chart
Dim oChtShp As Shape
Dim oLegShp As Shape
If ActiveWindow.Selection.ShapeRange(1).HasChart Then
Set oChtShp = ActiveWindow.Selection.ShapeRange(1)
Set oChart = oChtShp.Chart
Set oLegShp = oChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 100, 100) 'This line errors with Type Mismatch
oLegShp.Fill.ForeColor.RGB = RGB(0, 0, 0)
End If
End Sub
Excel and PowerPoint behave as expected, but Word errors out with a Type Mismatch when it tries to set the shape reference to an added text box. Any ideas or workarounds?
If you try to run the code, create a sample chart in Word, then set it to be floating in front of the text. Otherwise, Word sees it as an Inline Shape, which is a whole other can of worms.
I'm running Version 2205 (Build 15225.20288 Click-to-Run) under Windows 10.
(Edit) A kludge to get around the bug:
oChart.Shapes.AddTextbox msoTextOrientationHorizontal, 100, 100, 100, 100
For x = 1 To oChart.Shapes.Count
If oChart.Shapes(x).Left = LegLeft And oChart.Shapes(x).Top = LegTop Then
oChart.Shapes(x).Fill.ForeColor.RGB = RGB(0,0,0)
End If
Next x
I have to run many bar charts in excel 2016, each one showing the company performance over the seasons, for a certain country. On top of each bar I'd like to see the %Change in this format [Color10]0%"▲";[Red] -0%"▼". Reason why I added the data labels, and I used the function "value from cells" to show the %Change instead of the amount sold. Now everything is in place, and my percentages are nicely placed on top of the bars, but no way I can color them automatically (positive green and negative red). I tried formatting the labels directly from the format window placed under "numbers", but I discovered it doesn't work at all when the label content is derived using "value from cells".
So I started looking into VBA, but since I'm pretty ignorant about programming, I didn't succeed. I'm looking for a code that changes the data labels of my chart so that they maintain the font of the source (in the source my %Change values are already in the desired format ([Color10]0%"▲";[Red] -0%"▼"). Googling I found different solutions but none worked. I'll post the ones I that look better to me.
Sub legend_color()
Dim SRS As Series
With ActiveChart
For Each SRS In .SeriesCollection
SRS.ApplyDataLabels AutoText:=True, LegendKey:= _False,
ShowSeriesName:=False,
ShowCategoryName:=False,
ShowValue:=True, _ ShowPercentage:=False,
ShowBubbleSize:=False
SRS.DataLabels.Font.ColorIndex = SRS.Border.ColorIndex
Next SRS
End With
End Sub
This one was the only one that actually run, and colored my labels all white. With the following I run into errors.
Sub color_labels()
Dim chartIterator As Integer,
pointIterator As Integer, _seriesArray() As Variant
For chartIterator = 1 To ActiveSheet.ChartObjects.Count
seriesArray=ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _Chart.SeriesCollection(1).Values For pointIterator = 1 To UBound(seriesArray)
If seriesArray(pointIterator) >= 0 Then
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
Chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _RGB(146, 208, 80)
Else
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _Chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _RGB(255, 0, 0)
End If
Next pointIterator
Next chartIterator
End Sub
Sub ArrowColour()
Dim ncars As Integer
ncars = Range("A1").Value
With ActiveSheet.Shapes.Range(Array("Down Arrow 1")).Fill
If ncars > 0 Then
.ForeColor.RGB = RGB(0, 176, 80)
Else
.ForeColor.RGB = RGB(255, 0, 0)
End If
End With
End Sub
Option Explicit
Sub ApplyCustomLabels()
Dim rLabels As Range
Dim rCell As Range
Dim oSeries As Series
Dim Cnt As Integer
Set rLabels = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
Set oSeries = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
oSeries.HasDataLabels = True
Cnt = 1
For Each rCell In rLabels
With oSeries.Points(Cnt).DataLabel.Text = rCell.Value.Font.Color =rCell.Font.Color
End With
Cnt = Cnt + 1
Next rCell
End Sub
Thank you very much in advance for all of your help,
Tommaso
If you're just missing the colors then you can format each label using something like:
Sub Tester()
Dim s As Series, dl As DataLabels, d As DataLabel
Dim i As Long, rngLabels
Set s = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
Set dl = s.DataLabels
'Option 1: set label color based on label value
For i = 1 To dl.Count
With dl(i)
.Font.Color = IIf(Val(.Text) < 0, vbRed, vbGreen)
End With
Next i
'Option 2: set label color based on label source cell
' Note use of DisplayFormat to pick up custom
' formatting colors
Set rngLabels = Range("C7:C13")'<< source range for data labels
For i = 1 To dl.Count
dl(i).Font.Color = rngLabels(i).DisplayFormat.Font.Color
Next i
End Sub
I have looked for GetDIBits all over and only seem to find discussion in every other application other than Excel 2016.
I keep getting back 0 for all of the pixel values. I don't know if using Image1.Picture.Handle is the proper statement for the hdc, and I don't know if Image1.Picture is the proper statement for the hbitmap.
I can't even get a result to show up in an image box using the SetDIBits function.
Most of the content on the web uses PictureBox, and Autodraw, and stuff that doesn't seem to be in Excel.
Can anyone please help me solve this problem. It would be greatly appreciated. I would post all the Declarations but I didn't want to be booted of the site my question was too long. Thanks in advance.
Private Sub CommandButton2_Click() 'Userform command button
Dim X As Long 'X coordinates for the pixels
Dim Y As Long 'Y coordinates for the pixels
Dim sw As BITMAP
Dim bmapinfo As BITMAPINFO 'Information about the bitmap
Dim xtPixels() As RGBPixel 'Array to place pixel data into
Dim oPic As IPictureDisp 'Declaration of picture used in this program
Set oPic = Image1.Picture 'making the picture an object
'All of the data below gives information about the picture
bmapinfo.bmiHeader.biSize = 40
bmapinfo.bmiHeader.biWidth = oPic.Width
bmapinfo.bmiHeader.biHeight = oPic.Height
bmapinfo.bmiHeader.biPlanes = 1
bmapinfo.bmiHeader.biBitCount = 24
'bmapinfo.bmiHeader.biCompression = BI_RGB
bmapinfo.bmiHeader.biXPelsPerMeter = ((((bmapinfo.bmiHeader.biWidth * bmapinfo.bmiHeader.biBitCount) + _
31) \ 32) * 4)
bmapinfo.bmiHeader.biYPelsPerMeter = bmapinfo.bmiHeader.biXPelsPerMeter - (((bmapinfo.bmiHeader.biWidth _
* bmapinfo.bmiHeader.biBitCount) + 7) \ 8)
bmapinfo.bmiHeader.biSizeImage = bmapinfo.bmiHeader.biXPelsPerMeter * Abs(bmapinfo.bmiHeader.biHeight)
' GetObjectAPI voPicture.Handle, LenB(tBmp), tBmp
' nBitCount = tBmp.bmWidth * tBmp.bmBitsPixel * tBmp.bmHeight \ 4
ReDim xtPixels(1 To bmapinfo.bmiHeader.biWidth, 1 To bmapinfo.bmiHeader.biHeight)
'All of the data above gives information about the picture
GetDIBits Image1.Picture.Handle, sw.bmBitsPixel, _
0, bmapinfo.bmiHeader.biHeight, xtPixels(1, 1), bmapinfo, _
DIB_RGB_COLORS
For Y = 1 To UBound(xtPixels, 1) - 1
For X = 1 To UBound(xtPixels, 2) - 1
'With xtPixels(Y, X)
xtPixels(Y, X).Blue = xtPixels(Y, X).Blue
xtPixels(Y, X).Green = xtPixels(Y, X).Green
xtPixels(Y, X).Red = xtPixels(Y, X).Red
Next X, Y
SetDIBits oPic.Handle, oPic.Handle, _
0, bmapinfo.bmiHeader.biHeight, xtPixels(1, 1), _
bmapinfo, DIB_RGB_COLORS
'Set Image2.Picture = oPic.Render
End Sub
Code below was created (not by me, and saved as *.dotm) in Microsoft Word 97-2003, when default "insert shape/line" was black. Used as procedure template with specific cover page, header, outline style, etc. When the *.doc files are saved to *.docx, and the "SignoffLine" macro is activated, the inserted line's color is blue (MS Word 2010 default for Insert Shape/Line?).
I can change the default color per document, and I can change it via Normal.dotm, but want to edit the macro below so inserted line is always black.
Sub SignoffLine()
On Error GoTo endthis
i = Selection.Information(wdVerticalPositionRelativeToPage)
Set oFFline = ActiveDocument.Shapes.AddLine(554, i + 12, 524, i + 12).Line
With oFFline.Line
.Weight = 0.75
End With
oFFline.Name = "hline" & idi
idi = idi + 1
endthis:
End Sub
It's quite simple... You need to define oFFline object as a Shape and then to set its properties as follow:
Sub SignoffLine()
Dim oFFline As Shape
Dim i As Integer
On Error GoTo endthis
i = Selection.Information(wdVerticalPositionRelativeToPage)
Set oFFline = ActiveDocument.Shapes.AddLine(554, i + 12, 524, i + 12)
With oFFline.Line
.Weight = 0.75
'set black color
.ForeColor.RGB = RGB(0, 0, 0)
End With
oFFline.Name = "hline" & idi
idi = idi + 1
endthis:
Set oFFline = Nothing
End Sub
For further information, please see: Shape Object (Word) and RGB
In Excel vba, I am creating two shapes in excel using vba. An arrow, which I name "aro" + i, and a textbox, which I name "text" + i, where i is a number indicating the number of a photograph.
So, say for photograph 3 I will creat arrow "aro3" and textbox "text3".
I then want to group them and rename that group "arotext" + i, so "arotext3" in this instance.
So far I have been doing the grouping and renaming like this:
targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name)).Select
Selection.group
Selection.Name = "AroTxt" & Number
which works splendidly in a sub, but now I want to change this into a function and return the named group, so I tried something like this:
Dim arrowBoxGroup as Object
set arrowBoxGroup = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
arrowBoxGroup.group
arrowBoxGroup.Name = "AroTxt" & Number
I run into problems when I create a new group which has the same name as one which has already been created. So, if I create a second "aro3" and "text3" and then try to group them and rename the group to "arotext3" I get an error because a group with the same name is already present.
The thing I don't understand is that when I did this using the method referring to the selection, I could rename every group with the same name if I wanted and wouldn't get an error. Why does it work when referring to the Selection object, but fails when trying to use an assigned object?
UPDATE:
Since somebody asked, the code I have so far is below. arrow and textbox are an arrow and a textbox which point into a direction arbitrarily defined by the user using a form.
This then creates an arrow at the correct angle on the target worksheet and places a textbox with the specified number (also through the form) at the end of the arrow, so that it effectively forms a callout. I know that there are callouts, but they don't do what I want so I had to make my own.
I have to group the textbox and arrow because 1) they belong together, 2) I keep track of which callouts have already been placed using the group's name as a reference, 3) the user has to place the callout in the right location on a map which is embedded in the worksheet.
So far I have managed to make this into a function by making the return value a GroupObject. But this still relies on Sheet.Shapes.range().Select, which in my opinion is a very bad way of doing this. I am looking for a way which does not rely on the selection object.
And I would like to understand why this works when using selection, but fails when using strong typed variables to hold the objects.
Public Function MakeArrow(ByVal No As Integer, ByVal angle As Double, ByVal size As ArrowSize, ByVal ArrowX As Double, ByVal ArrowY As Double, ByVal TargetInternalAngle As Double, ByRef targetSheet As Worksheet) As GroupObject
Dim Number As String
Dim fontSize As Integer
Dim textboxwidth As Integer
Dim textboxheight As Integer
Dim arrowScale As Double
Dim X1 As Double
Dim Y1 As Double
Dim X2 As Double
Dim Y2 As Double
Dim xBox As Double
Dim yBox As Double
Dim testRange As Range
Dim arrow As Shape
Dim textBox As Shape
' Dim arrowTextbox As ShapeRange
' Dim arrowTextboxGroup As Variant
Select Case size
Case ArrowSize.normal
fontSize = fontSizeNormal
arrowScale = arrowScaleNormal
Case ArrowSize.small
fontSize = fontSizeSmall
arrowScale = arrowScaleSmall
Case ArrowSize.smaller
fontSize = fontSizeSmaller
arrowScale = arrowScaleSmaller
End Select
arrowScale = baseArrowLength * arrowScale
'Estimate required text box width
Number = Trim(CStr(No))
Set testRange = shtTextWidth.Range("A1")
testRange.value = Number
testRange.Font.Name = "ＭＳ Ｐ明朝"
testRange.Font.size = fontSize
shtTextWidth.Columns(testRange.Column).EntireColumn.AutoFit
shtTextWidth.Columns(testRange.row).EntireRow.AutoFit
textboxwidth = testRange.Width * 0.8
textboxheight = testRange.Height * 0.9
testRange.Clear
'Make arrow
X1 = ArrowX
Y1 = ArrowY
X2 = X1 + arrowScale * Cos(angle)
Y2 = Y1 - arrowScale * Sin(angle)
Set arrow = AddArrow(X1, Y1, X2, Y2, Number, targetSheet)
'Make text box
Set textBox = Addtextbox(angle, Number, fontSize, X2, Y2, textboxwidth, textboxheight, TargetInternalAngle, targetSheet)
'Group arrow and test box
targetSheet.shapes.Range(Array(arrow.Name, textBox.Name)).group.Select
Selection.Name = "AroTxt" & Number
Set MakeArrow = Selection
' Set arrowTextbox = targetSheet.shapes.Range(Array(arrow.Name, textBox.Name))
' Set arrowTextboxGroup = arrowTextbox.group
' arrowTextboxGroup.Name = "AroTxt" & Number
'
' Set MakeArrow = arrowTextboxGroup
End Function
Private Function AddArrow(ByVal StartX As Double, ByVal StartY As Double, ByVal EndX As Double, ByVal EndY As Double, ByVal Number As String, ByRef targetSheet As Worksheet) As Shape
Set AddArrow = targetSheet.shapes.AddLine(StartX, StartY, EndX, EndY)
With AddArrow
.Name = "Aro" & Number
With .Line
.BeginArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadLength = msoArrowheadLengthMedium
.BeginArrowheadWidth = msoArrowheadWidthMedium
.ForeColor.RGB = RGB(0, 0, 255)
End With
End With
End Function
Private Function Addtextbox(ByVal angle As Double, ByVal Number As String, ByVal fontSize As Integer, ByVal arrowEndX As Double, ByVal arrowEndY As Double, ByVal Width As Integer, ByVal Height As Integer, ByVal LimitAngle As Double, ByRef targetSheet As Worksheet) As Shape
Dim xBox, yBox As Integer
Dim PI As Double
Dim horizontalAlignment As eTextBoxHorizontalAlignment
Dim verticalAlignment As eTextBoxVerticalAlignment
PI = 4 * Atn(1)
If LimitAngle = 0 Then
LimitAngle = PI / 4
End If
Select Case angle
'Right
Case 0 To LimitAngle, 2 * PI - LimitAngle To 2 * PI
xBox = arrowEndX
yBox = arrowEndY - Height / 2
horizontalAlignment = eTextBoxHorizontalAlignment.left
verticalAlignment = eTextBoxVerticalAlignment.Center
'Top
Case LimitAngle To PI - LimitAngle
xBox = arrowEndX - Width / 2
yBox = arrowEndY - Height
horizontalAlignment = eTextBoxHorizontalAlignment.Middle
verticalAlignment = eTextBoxVerticalAlignment.Bottom
'Left
Case PI - LimitAngle To PI + LimitAngle
xBox = arrowEndX - Width
yBox = arrowEndY - Height / 2
horizontalAlignment = eTextBoxHorizontalAlignment.Right
verticalAlignment = eTextBoxVerticalAlignment.Center
'Bottom
Case PI + LimitAngle To 2 * PI - LimitAngle
xBox = arrowEndX - Width / 2
yBox = arrowEndY
horizontalAlignment = eTextBoxHorizontalAlignment.Middle
verticalAlignment = eTextBoxVerticalAlignment.top
End Select
Set Addtextbox = targetSheet.shapes.Addtextbox(msoTextOrientationHorizontal, xBox, yBox, Width, Height)
With Addtextbox
.Name = "Txt" & Number
With .TextFrame
.AutoMargins = False
.AutoSize = False
.MarginLeft = 0#
.MarginRight = 0#
.MarginTop = 0#
.MarginBottom = 0#
Select Case verticalAlignment
Case eTextBoxVerticalAlignment.Bottom
.verticalAlignment = xlVAlignBottom
Case eTextBoxVerticalAlignment.Center
.verticalAlignment = xlVAlignCenter
Case eTextBoxVerticalAlignment.top
.verticalAlignment = xlVAlignTop
End Select
Select Case horizontalAlignment
Case eTextBoxHorizontalAlignment.left
.horizontalAlignment = xlHAlignLeft
Case eTextBoxHorizontalAlignment.Middle
.horizontalAlignment = xlHAlignCenter
Case eTextBoxHorizontalAlignment.Right
.horizontalAlignment = xlHAlignRight
End Select
With .Characters
.Text = Number
With .Font
.Name = "ＭＳ Ｐ明朝"
.FontStyle = "標準"
.size = fontSize
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End With
.Fill.Visible = msoFalse
.Fill.Solid
.Fill.Transparency = 1#
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.style = msoLineSingle
.Transparency = 0#
.Visible = msoFalse
End With
End With
End Function
Range.Group returns a value. You might try:
Set arrowBoxRange = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
Set arrowBoxGroup = arrowBoxRange.Group
arrowBoxGroup.Name = "AroTxt" & Number
I suspect that the current Selection gets updated as if the following in your earlier work:
Set Selection = Selection.Group 'it's as if this is done for you when you create the group.
which is causing the difference.
FYI, I'm using Excel 2010 and cannot duplicate the original code snippet based on Selection (I get an error doing "Selection.Name = ", which gives object does not support property.)
Ok, I can get this to work:
Selection.Group.Select
Selection.Name = "AroTxt"
Of course, like the other snippet I suggest, this reassigns the group's return value, so that Selection in Selection.Group and Selection.Name are referring to different objects, which I think is what you want.
It is because you are storing the new groups as an object manually now that this error has appeared. You probably are not able to do anything with the multiple instances of "AroTxt" & Number that you have created. As excel wouldn't be able to decide which group you mean.
Excel shouldn't allow this but it doesn't always warn that this has happened but will error if you try to select a group that has a duplicate name.
Even if this isn't the case, it isn't good practice to have duplicate variable names. Would it not be better to add the extra Arrow's and textBox's to the group?
So to solve your problem you will have to check to see if the group already exists before you save it. Maybe delete it if exists or add to the group.
Hope this helps
Edit: As it always seems to go, the error started popping up after I clicked submit. I'll tinker around a bit more, but will echo #royka in wondering if you really do need to give the same name to multiple shapes.
The below code seems to do what you're looking for (create the shapes, give them names and then group). In the grouping function, I left the "AroText" number the same just to see if an error would happen (it did not). It seems that both shapes have the same name, but what differentiates them is their Shape.ID. From what I can tell, if you say ActiveSheet.Shapes("My Group").Select, it will select the element with that name with the lowest ID (as to why it lets you name two things the same name, no clue :) ).
It isn't quite an answer to your question of "why" (I wasn't able to replicate the error), but this will hopefully give you one way "how".
Sub SOTest()
Dim Arrow As Shape
Dim TextBox As Shape
Dim i as Integer
Dim Grouper As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
' Make two shapes and group, naming the group the same in both cases
For i = 1 To 2
' Create arrow with name "Aro" & i
Set Arrow = ws.Shapes.AddShape(msoShapeRightArrow, 10, 50, 30, 30)
Arrow.Name = "Aro" & i
' Create text box with name "Text" & i
Set TextBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 50, 40, 40)
TextBox.Name = "Text" & i
' Use a group function to rename the shapes
Set Grouper = CreateGroup(ws, Arrow, TextBox, i)
' See the identical names but differing IDs
Debug.Print "Name: " & Grouper.Name & " | ID: " & Grouper.ID
Next
End Sub
Function CreateGroup(ws As Worksheet, Arrow As Shape, TextBox As Shape, Number As Integer) As Variant
Dim arrowBoxGroup As Variant
' Group the provided shapes and change the name
Set arrowBoxGroup = ws.Shapes.Range(Array(Arrow.Name, TextBox.Name)).Group
arrowBoxGroup.Name = "AroTxt" & Number
' Return the grouped object
Set CreateGroup = arrowBoxGroup
End Function