赤枠付与 

エクセル中に赤枠シェイプを出現させるマクロ

ホットキーに割り当てると使いやすい。
選択中のセル範囲の大きさでカーソル位置に赤枠シェイプを出現させる。
セル選択後にスクロールすると出現位置がずれるため要注意。

'ポインタAPI。マウスカーソル位置からセル位置を取得するために使用する
Private Type POINTAPI
    x As Long
    y As Long
End Type
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'選択セル範囲で赤枠を作成する
Sub onShapeWithRedBoxLine()

    Dim onShape As shape
    Dim beforeRange As Range
    
 On Error GoTo ErrHndl
    '処理前後で選択セル位置を保持するため
    Set beforeRange = Selection
    
    'シェイプ生成&スタイル設定
    '■第一引数は以下のURLを参考に変更可。シェイプの形を指定する
    'https://learn.microsoft.com/ja-jp/office/vba/api/office.msoautoshapetype?redirectedfrom=MSDN
    Set onShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                                            Selection.left, _
                                            Selection.top, _
                                            Selection.width, _
                                            Selection.height)
    '■塗りつぶしなし
    onShape.Fill.Visible = msoFalse
    '■線の太さ。お好みでどうぞ
    onShape.Line.Weight = 4
    '■色指定
    onShape.Line.ForeColor.RGB = RGB(255, 0, 0)
    '■塗りつぶし色指定
    'onShape.Fill.ForeColor.RGB = RGB(255, 255, 255)
    
    '画像の上にカーソルがある状態では構造処理ができないため、一時非表示にする
    'この段階でどの画像上にカーソルがあるか不明なので全シェイプを対象とする
    For Each shape In ActiveSheet.Shapes
        shape.Visible = False
    Next
    
    '次の処理のために、マウスカーソル状態を解放する
    beforeRange.Select
    
    '以下で上記作成シェイプをマウスがあるセルの位置に移動させる
    Dim p As POINTAPI
    Dim Getcell As Range

    'カーソル位置を取得
    GetCursorPos p

    'マウスカーソルの位置からセルを取得(カーソルの状態次第では失敗する)
    Set Getcell = ActiveWindow.RangeFromPoint(p.x, p.y)

    'シェイプ位置をマウスカーソルの直近セルの左上に合わせる
    onShape.top = Getcell.top
    onShape.left = Getcell.left
    
    '全シェイプを可視状態に戻す
    For Each shape In ActiveSheet.Shapes
        shape.Visible = True
    Next
    Exit Sub
ErrHndl:
    'MsgBox "エラー発生"
    '全シェイプを可視状態に戻す
    For Each shape In ActiveSheet.Shapes
        shape.Visible = True
    Next

End Sub

Public shape As shape
Public beforeRange As Range

Private Type POINTAPI
    x As Long
    y As Long
End Type
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'選択セル範囲で赤箱を作成する
Sub addShapeWithRedBoxLine()
    
 On Error GoTo ErrHndl
    Dim top As Integer
    Dim left As Integer
    Dim height As Integer
    Dim width As Integer
    'セルの位置・サイズを設定
    top = Selection.top
    left = Selection.left
    height = Selection.height
    width = Selection.width
    Set beforeRange = Selection
    'シェイプ生成&スタイル設定
    Set shape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, width, height)
    shape.Fill.Visible = msoFalse
    shape.Line.Weight = 4
    shape.Line.ForeColor.RGB = RGB(255, 0, 0)
    
    Dim shp As shape
    For Each shpe In ActiveSheet.Shapes
        shpe.Visible = False
    Next
    'シェイプの選択状態を解除するために必要(1行目など固定値はだめ。貼り付け位置に影響するから。貼り付け位置、マウスの座標を基準にセル合わせで取得するから)
    beforeRange.Select
    '以下で上記作成シェイプをマウスがあるセルの位置に移動させる
    Dim p As POINTAPI
    Dim Getcell As Range

    'カーソル位置を取得
    GetCursorPos p

    'マウスカーソルの位置からセルを取得(カーソルの状態次第では失敗する)
    Set Getcell = ActiveWindow.RangeFromPoint(p.x, p.y)

    'シェイプ位置をマウスカーソルの直近セルの左上に合わせる
    shape.top = Getcell.top
    shape.left = Getcell.left
    '赤箱シェイプ登場
    shape.Visible = True
    '貼付対象シェイプを可視状態に戻す
        For Each shpe In ActiveSheet.Shapes
        shpe.Visible = True
    Next
ErrHndl:
    'MsgBox "エラー発生!やりなおし!"
    For Each shpe In ActiveSheet.Shapes
        shpe.Visible = True
    Next

End Sub

以下おまけ。

'選択中の画像を最背面にする
Sub selectShapeBackToZOrder0()
On Error GoTo ErrHndl
    Selection.ShapeRange.ZOrder msoSendToBack
    Exit Sub
ErrHndl:
MsgBox "図形を選択してから実行してください。"
End Sub


コメント