Little easy object placement macro

[Joe]

Hi all!

Haven't been here for a loooong time, but made this super-simple little macro for a task and thought maybe it could come in handy to someone, it's kinda neat.

What it does is it takes a bunch (or just one) of objects and then as you click it places a copy of a random object at a random angle. Here's an example:



So you want to place those sea-things onto the water. Normally arranging them would be quite a chore, here you just select all the objects on top, start the macro, click like crazy, then press ESC to cancel the placement mode and get this:



You can undo any placement or right click to move them mid-placement and, of course, change the positions after you are done placing. But it's a good start. Here's the code, I hope someone finds it useful:

Sub ObPlacer()
  If ActiveSelection.Shapes.Count = 0 Then
    MsgBox "Please select at least one object.", vbOKOnly

    Exit Sub
    End If

    Dim X As Double, Y As Double
    Dim b As Boolean
    Dim s As Shape
    Dim Pool As ShapeRange
    Dim Count As Single, WhichOne As Single

    Set Pool = ActiveSelectionRange
    Count = Pool.Shapes.Count

    b = False

    While Not b
    
    b = ActiveDocument.GetUserClick(X, Y, 0, 10, False, cdrCursorSmallcrosshair)
        If Not b Then
          WhichOne = Int(Rnd * Count + 1)
          ActiveDocument.BeginCommandGroup ("Placed Object")
          Set s = Pool.Shapes(WhichOne).Duplicate(X - Pool.Shapes(WhichOne).CenterX, Y - Pool.Shapes(WhichOne).CenterY)
          s.Rotate (Rnd * 360)
          ActiveDocument.EndCommandGroup
        End If
    Wend
  End Sub

If/when I finally get my brain to understand shelby's excellent new X6 docker tutorial I might try to make a proper version with settings and such.