Copy another objects Height or Width

[dungbtl]

Any code for copying another objects Width OR Height?
Either one but not both, not proportional.
So I guess 8 code snippets? Just difining which direction.

I have at least over a 100+ shortcuts so a few more
isnt going to hurt.

Im thinking maybe I could use Alt+Shift along with
QWE/ASD/ZXC to resemble the normal sizing grid.
Skip S, wont work or maybe that could match same size height/width?

Sometimes grabbing the handle bar and drag to snap is a PITA
so a shortcut would be a helluva lot faster.

I would assume you need to select the desired object to change size,
invoke shortcut then cursor turns to an arrow,
next would be to choose the "sized" object to match in length/height.

Is this possible?

[shark]

I think you can use ActiveDocument.GetUserClick. 3rd parameter returns ShiftState, i.e. whether the keys Ctrl, Shift and Alt are pressed.

b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, 31)
If Not b Then
   With ActivePage.SelectShapesAtPoint(x, y, SelectUnfilled:=True)
        If .Shapes.Count = 0 Then Beep: Exit Sub
        Set s = .Shapes(.Shapes.Count)
    End With
    s.GetBoundinBox x, y, w, h
    If (Shift And 1) = 1 Then 'set Width only
    elseIf (Shift And 2) = 2 Then ' set Height only
    else 'set same width/height

[dungbtl]

Thanks shark but doesnt do anything, Compile Error.

Isnt the code partial?

[shark]

Here is ready macro, works with Ctrl/Shift/without

Private Sub CopyWH()
Dim s As Shape, cs As Shape, w#, h#, b As Boolean, Shift&
    Set cs = ActiveShape: If cs Is Nothing Then Exit Sub
    b = ActiveDocument.GetUserClick(w, h, Shift, -1, True, 309)
    If Not b Then
        With ActivePage.SelectShapesAtPoint(w, h, SelectUnfilled:=True)
            If .Shapes.Count = 0 Then Beep: Exit Sub
            Set s = .Shapes(.Shapes.Count)
        End With
        s.GetSize w, h
        If (Shift And 1) = 1 Then
            cs.SetSize w
        ElseIf (Shift And 2) = 2 Then
            cs.SetSize , h
        Else
            cs.SetSize w, h
        End If
    End If
End Sub

[dungbtl]

Oh man Shark.... sorry for the late reply. Very Bizzie.

Thanks for this... need some time to digest it though.

Any way to get it to remove Proportionate sizing?

Otherwise it's working good.

So its either the Height & No Width (CTRL) or Width & No Height (Shift)
Obviously nothing pressed is same size as selected.

Sorry for the PITA questions.

How could I get it to size from the side I select?
If I select the Right side of an object, how to size the new objects
width to go left? Or select Bottom to go up? Etc Etc Etc
for all sides. Possible?

Lol... i played around with the code, tried this/that.
I have no clue nor time to understand it. Some is easy
to figure out. Errors aren't.

Thanks again for your troubles!

[shark]

Private Sub CopyWH()
Dim s As Shape, cs As Shape, w#, w1#, h#, h1#, b As Boolean, Shift&
    Set cs = ActiveShape: If cs Is Nothing Then Exit Sub
    cs.GetSize w1, h1  'get source size
    b = ActiveDocument.GetUserClick(w, h, Shift, -1, True, 309)
    If Not b Then
        With ActivePage.SelectShapesAtPoint(w, h, SelectUnfilled:=True)
            If .Shapes.Count = 0 Then Beep: Exit Sub
            Set s = .Shapes(.Shapes.Count)
        End With
        s.GetSize w, h
        If (Shift And 1) = 1 Then
            cs.SetSize w, h1   'apply new width and old height
        ElseIf (Shift And 2) = 2 Then
            cs.SetSize w1, h   'apply old width and new height
        Else
            cs.SetSize w, h
        End If
    End If
End Sub

If I select the Right side of an object

You mean - select two nodes on right side?

[dungbtl]

Forget that.... This is ideal!! Works for me.
Dont need to get more complicated.

What about multiple objects... is that a shaperange?

I'll draw up what I was referring to in a few.

Thnaks