Sub オートシェイプの線をまっすぐにする()

'------------------------------------------------------------------------------
'オートシェイプの線をまっすぐにする
'1.高さ→2.幅の順でチェックして、片方だけ検出
'------------------------------------------------------------------------------
Dim MsgRtn As Long          'メッセージの返り値

Dim lnglimitCM As Single    '検出対象の長さ(cm)
Dim lngLimit As Long        '検出対象の長さ
Dim s As Shape              'オートシェイプ
Dim blnHeight As Boolean    '高さで検出
Dim blnWidth As Boolean     '幅で検出
Dim strMsgHeight As String  '高さで検出したときのメッセージ可変部
Dim strMsgWidth As String   '幅で検出したときのメッセージ可変部

'UI上のcmをpointに変換。0.2cm以下のものだけチェック
lnglimitCM = 0.2
lngLimit = Application.CentimetersToPoints(lnglimitCM)

For Each s In ActiveSheet.Shapes

    '線と線矢印に有効
    If InStr(s.Name, "Straight Connector") > 0 Or InStr(s.Name, "Straight Arrow Connector") > 0 Then
        
        'フラグ等初期化
        blnHeight = False
        blnWidth = False
        strMsgHeight = ""
        strMsgWidth = ""
        
        '高さが検出対象の長さ以下
        If 0 < s.Height And s.Height <= lngLimit Then
            blnHeight = True
            strMsgHeight = " →0★"
        '幅が検出対象の長さ以下
        ElseIf 0 < s.Width And s.Width <= lngLimit Then
            blnWidth = True
            strMsgWidth = " →0★"
        End If
        If blnWidth = True Or blnHeight = True Then
            '次のメッセージ出すタイミングでオートシェイプ選択して、見えるようにウィンドウ位置合わせ
            s.Select
            If s.TopLeftCell.Row > 5 Then
                ActiveWindow.ScrollRow = s.TopLeftCell.Row - 5
            Else
                ActiveWindow.ScrollRow = 1
            End If
            If s.TopLeftCell.Column > 5 Then
                ActiveWindow.ScrollColumn = s.TopLeftCell.Column - 5
            Else
                ActiveWindow.ScrollColumn = 1
            End If
            '確認メッセージ
            MsgRtn = MsgBox("選択した線をまっすぐにしますか？" & vbCrLf & vbCrLf & _
                        "【" & s.Name & "】" & vbCrLf & _
                        "高さ（ポイント）: " & s.Height & strMsgHeight & vbLf & _
                        "幅  （ポイント）: " & s.Width & strMsgWidth & vbLf & vbLf & _
                        "検出対象は " & lngLimit & " ポイント ( " & lnglimitCM & " cm) " & "以下です。" & vbLf, _
                        vbYesNoCancel + vbInformation, Title:="確認")
            'Cancel選択時は中断
            If MsgRtn = vbCancel Then
                Exit Sub
            'Yes選択時に高さまたは幅を0にする
            ElseIf MsgRtn = vbYes Then
                If blnHeight = True Then
                    s.Height = 0
                ElseIf blnWidth = True Then
                    s.Width = 0
                End If
            End If
            
        End If
    End If
Next s

Set s = Nothing

End Sub