shapes catch nodes by VBA

[WernerHo]

Hi Shark
I don't think, that you have the time to analyze the complete thing, because there is much different work in it.
I tried to upload a xlsm, but it dindn't work, because it's "not a valid file"...

Don't worry, I will get further with the tipps you gave 'til now.
Thanks a lot!!
Werner

[shark]

OK.
I slightly improved your code:

Sub Thor_o_Mat()
Dim shp As Shape, SB As Double, SH As Double, sC As Shape
Dim OrigSelection As ShapeRange
Dim PY As Double, PX As Double
    ActiveDocument.BeginCommandGroup "Schilder"
    Optimization = True
    EventsEnabled = False
    'ActiveDocument.SaveSettings
    ActiveDocument.PreserveSelection = False
    
    ActiveLayer.Paste
    Set OrigSelection = ActiveSelectionRange

    For Each shp In OrigSelection
    
    Set sC = shp.Shapes.FindShape(, cdrCurveShape) 'Find curved rectangle in group-shape. Or not rectangle
    If Not sC Is Nothing Then
        With sC
            SB = Round((shp.SizeWidth * 2.54), 0)
            SH = Round((shp.SizeHeight * 2.54), 0)
            SB = SB / 2.54 + 0.005
            SH = SH / 2.54 + 0.005
            .Fill.ApplyNoFill
'PX = shp.PositionX
'PY = shp.PositionY

            .SizeHeight = SH
            .SizeWidth = SB
'        .PositionX = PX - 0.02
'        .PositionY = PY + 0.02
            .Outline.SetProperties 0.003, , CreateRGBColor(255, 0, 0)
        End With
    End If

    Next shp
    ActiveDocument.PreserveSelection = True
    'ActiveDocument.RestoreSettings
    EventsEnabled = True
    Optimization = False
    ActiveDocument.EndCommandGroup
    ActiveWindow.Refresh
    Application.Refresh
End Sub

To arrange objects you can take my old macros
https://forum.oberonplace.com/showthread.php?t=7563
or modify this code

Sub ArrangeRight() 'Places shapes one after another left-to right
    Dim sr As ShapeRange
    Dim cnt%, x#, y#, w#, H#
    Set sr = ActiveSelectionRange
    If sr.Count < 2 Then Exit Sub
    ActiveDocument.ReferencePoint = cdrTopLeft
    ActiveDocument.Unit = cdrMillimeter

    ActiveDocument.BeginCommandGroup "Arrange_right"
    For cnt = 2 To sr.Count
        sr(cnt - 1).GetBoundingBox x, y, w, H, True
        sr(cnt).SetPosition x + w, y + H
    Next cnt
    ActiveDocument.EndCommandGroup
End Sub

[WernerHo]

Hello Shark
many, many thanks for your effort!!
I will look at this code an your Macro as soon as possible.
If I get it all to work I will give you a Feedback.
Thank you so much!!
Regards
Werner