Hotkey For Rectangle "Scale Height & Scale Width"

[soubasa]

Hello
I need Hotkey for change Scale Height and Scale Width of Rectangle

VBA code or Macro is awesome


Thank you in advance for your answer

[ByteMarks]

Maybe something like this:

In the ThisWorkbook code

Private Sub Workbook_Activate()
Call assign(True)
End Sub

Private Sub Workbook_Open()
Call assign(False)
End Sub

Then in a standard module
Ctrl+arrows will then scale the shape according to the constants.

Sub assign(OnOff As Boolean)
Const L As Single = 0.2
Const R As Single = 1.2
Const D As Single = 1.2
Const U As Single = 0.2

With Application
    If OnOff Then
        .OnKey "^{LEFT}", "'ScaleShape " & L & "," & """LR""" & "'"
        .OnKey "^{RIGHT}", "'ScaleShape " & R & "," & """LR""" & "'"
        .OnKey "^{UP}", "'ScaleShape " & U & "," & """UD""" & "'"
        .OnKey "^{DOWN}", "'ScaleShape " & D & "," & """UD""" & "'"
    Else
        .OnKey "^{LEFT}", ""
        .OnKey "^{RIGHT}", ""
        .OnKey "^{UP}", ""
        .OnKey "^{DOWN}", ""
    End If
End With
End Sub


Sub ScaleShape(v As Single, Which$)
Dim shp As Shape
If TypeName(Selection) = "Rectangle" Then
    Set shp = ActiveSheet.Shapes(Selection.Name)
    With shp
        .LockAspectRatio = msoFalse
        Select Case Which
            Case "LR"
                .ScaleWidth v, msoFalse
            Case "UD"
                .ScaleHeight v, msoFalse
        End Select
        .LockAspectRatio = msoTrue
    End With
End If
End Sub

[soubasa]

Hello
Thanks for your time

I puted codes in VBA and save it as .xlsm but I didn't see change
could you please put the code in attach file

I need hotkey for change scale in percentage


I really appreciate of you

[ByteMarks]

Try these changes

Sub assign(OnOff As Boolean)
With Application
    If OnOff Then
        .OnKey "^{UP}", "'ScaleShape " & """UP""" & "'"
        .OnKey "^{DOWN}", "'ScaleShape " & """DN""" & "'"
    Else
        .OnKey "^{UP}", ""
        .OnKey "^{DOWN}", ""
    End If
End With
End Sub

Sub ScaleShape(Which$)
Dim shp As Shape
Dim Factor As Single
If TypeName(Selection) = "Rectangle" Then
    Set shp = ActiveSheet.Shapes(Selection.Name)
    If Which = "UP" Then
        Factor = 1.6
    Else
        Factor = 0.6
    End If
    With shp
        .Height = .Height * Factor
        .Width = .Width * Factor
    End With
End If
End Sub