Hi!
Could I have some guidance for creating a macro, that allows me to select objects such as in the above picture and measure
and show the distance between the middle point of the first object (different shape than the rest) and the middle point of rest of the objects.
I mean, if I select all of the above objects and click the macro, it then measures and shows the distance between all the circles and the line.
Hello, drawincorelI have 2 variants of code:The first of them is started pressing the command button of any form or from hotkey assigned to macro and return distance from blue object in mm.
Private Sub CommandButton4_Click()Dim BhBp_Shape, text1 As ShapeActivePage.Layers("DISTANCE_LAYER").Shapes.All.Delete
Start_CenterX = ActivePage.Shapes("Start").CenterXFor Each BhBp_Shape In ActivePage.ShapesIf BhBp_Shape.Name = "Start" ThenElse'Set MLINE8 = ActiveLayer.CreateLineSegment(Mleftx, Mtopy, Mleftx - tbLength.Text, Mtopy)'Set text1 = BhBp_Shape.Layer.CreateArtisticText(BhBp_Shape.CenterX, BhBp_Shape.CenterY, "OK")Set text1 = ActivePage.Layers("DISTANCE_LAYER").CreateArtisticText(BhBp_Shape.CenterX, BhBp_Shape.CenterY, (BhBp_Shape.CenterX - Start_CenterX) * 25.4)
'text1.CenterX = BhBp_Shape.CenterX'text1.CenterY = BhBp_Shape.CenterY
End If
NextEnd SubPressing command button prints distance of every shape except blue bar near the centre. Blue bar must have name Start
The second variant is attractive. When any of the shape is moved, distance value is refreshed with new actual value.
Code is at ThisDocument level
Private Sub Document_ShapeMove(ByVal Shape As Shape)
Dim BhBp_Shape, text1 As ShapeActivePage.Layers("DISTANCE_LAYER").Shapes.All.Delete
Start_CenterX = ActivePage.Shapes("Start").CenterXFor Each BhBp_Shape In ActivePage.ShapesIf BhBp_Shape.Name = "Start" Then'NullElseSet text1 = ActivePage.Layers("DISTANCE_LAYER").CreateArtisticText(BhBp_Shape.CenterX, BhBp_Shape.CenterY, (BhBp_Shape.CenterX - Start_CenterX) * 25.4)End IfNextEnd SubGreetings!
Improved code to print distance in centre of shapes without moving text. If move text then event ShapeMove fires and Document_ShapeMove cycles non stopPrivate Sub Document_ShapeMove(ByVal Shape As Shape)'MsgBox "shape is moved"
Dim BhBp_Shape, text1 As ShapeDim mSize As SingleActivePage.Layers("DISTANCE_LAYER").Shapes.All.DeleteStart_CenterX = ActivePage.Shapes("Start").CenterXFor Each BhBp_Shape In ActivePage.ShapesIf BhBp_Shape.Name = "Start" Then'NullElse'Set MLINE8 = ActiveLayer.CreateLineSegment(Mleftx, Mtopy, Mleftx - tbLength.Text, Mtopy)'Set text1 = BhBp_Shape.Layer.CreateArtisticText(BhBp_Shape.CenterX, BhBp_Shape.CenterY, "OK")mSize = 12Set text1 = ActivePage.Layers("DISTANCE_LAYER").CreateArtisticText(BhBp_Shape.CenterX, BhBp_Shape.CenterY, (BhBp_Shape.CenterX - Start_CenterX) * 25.4, , , , mSize)
text1_centerX = text1.CenterXtext1_centerY = text1.CenterYtext1.Delete
Set text1 = ActivePage.Layers("DISTANCE_LAYER").CreateArtisticText(BhBp_Shape.CenterX - (text1_centerX - BhBp_Shape.CenterX), BhBp_Shape.CenterY - (text1_centerY - BhBp_Shape.CenterY), (BhBp_Shape.CenterX - Start_CenterX) * 25.4, , , , mSize)
'With text1 'move shape and cycle'.CenterX = BhBp_Shape.CenterX'.CenterY = BhBp_Shape.CenterY'End WithEnd IfNextEnd Sub
Result of executing above code. Texts are centered in shapes.