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

Excel のオートシェイプの線及び線矢印が微妙に曲がっているのをまっすぐに補正します。
アクティブシートに対して動作し、オートシェイプごとに確認メッセージが出て、対象を確認しながら補正できます。
検出するズレは 0.2cm にしています。（0.3cm あたりになると線が曲がってることが視認できるため）

0.2 cm以下の長さの線がある場合には誤動作するので気をつけてください。

ダウンロード（txt）

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   '幅で検出したときのメッセージ可変部

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

For Each s In ActiveSheet.Shapes

    '線と線矢印に有効
    If InStr(s.Name, &quot;Straight Connector&quot;) > 0 Or InStr(s.Name, &quot;Straight Arrow Connector&quot;) > 0 Then
        
        'フラグ等初期化
        blnHeight = False
        blnWidth = False
        strMsgHeight = &quot;&quot;
        strMsgWidth = &quot;&quot;
        
        '高さが検出対象の長さ以下
        If 0 < s.Height And s.Height <= lngLimit Then
            blnHeight = True
            strMsgHeight = &quot; →0★&quot;
        '幅が検出対象の長さ以下
        ElseIf 0 < s.Width And s.Width <= lngLimit Then
            blnWidth = True
            strMsgWidth = &quot; →0★&quot;
        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(&quot;選択した線をまっすぐにしますか？&quot; & vbCrLf & vbCrLf & _
                        &quot;【&quot; & s.Name & &quot;】&quot; & vbCrLf & _
                        &quot;高さ（ポイント）: &quot; & s.Height & strMsgHeight & vbLf & _
                        &quot;幅  （ポイント）: &quot; & s.Width & strMsgWidth & vbLf & vbLf & _
                        &quot;検出対象は &quot; & lngLimit & &quot; ポイント ( &quot; & lnglimitCM & &quot; cm) &quot; & &quot;以下です。&quot; & vbLf, _
                        vbYesNoCancel + vbInformation, Title:=&quot;確認&quot;)
            '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