セルの中に良い感じで線矢印を描画したい　の続き（斜め線）

先日は、指定セルの中に良い感じで、線矢印を描画することに挑戦した。
infoment.hatenablog.com

今回は、水平垂直に加えて、斜め線の描画に挑戦する。
f:id:Infoment:20190717221123p:plain

さて、上下左右の指示については、XlDirectionのメンバーを利用して指定することが出来た。
f:id:Infoment:20190717221258p:plain

しかしこの中には、斜めを表すメンバーが存在しない。どうしてものか。
と、ここで活きてくるのが、昨日の「色の足し算」だ。
infoment.hatenablog.com

vbBlue + vbYellow

のごとく、例えば「右＋上」なら「左下から右上」と読むことが出来る。早速、前回のマクロに追記してみよう。

Function SetArrow(target_range As Range, _
         Optional arrow_direction As XlDirection = xlToRight) As Excel.Shape

    Dim Arrow As Excel.Shape
    ' 線矢印の始点。
    Dim Sx As Double, Sy As Double
    ' 線矢印の終点。
    Dim Ex As Double, Ey As Double

        With target_range
            Select Case arrow_direction
                ' 垂直：上から下へ
                Case XlDirection.xlDown
                    Sx = .Left + 0.5 * .Width
                    Sy = .Top
                    Ex = Sx
                    Ey = Sy + .Height
                ' 垂直：下から上へ
                Case XlDirection.xlUp
                    Sx = .Left + 0.5 * .Width
                    Sy = .Top + .Height
                    Ex = Sx
                    Ey = .Top
                ' 水平：左から右へ
                Case XlDirection.xlToRight
                    Sx = .Left
                    Sy = .Top + 0.5 * .Height
                    Ex = Sx + .Width
                    Ey = Sy
                ' 水平：右から左へ
                Case XlDirection.xlToLeft
                    Sx = .Left + .Width
                    Sy = .Top + 0.5 * .Height
                    Ex = .Left
                    Ey = Sy
                    
                ' 2019年7月16日追加
                ' 斜め：左上から右下へ
                Case XlDirection.xlToRight + XlDirection.xlDown
                    Sx = .Left
                    Sy = .Top
                    Ex = .Left + .Width
                    Ey = .Top + .Height
                ' 斜め：右上から左下へ
                Case XlDirection.xlToLeft + XlDirection.xlDown
                    Sx = .Left + .Width
                    Sy = .Top
                    Ex = .Left
                    Ey = .Top + .Height
                ' 斜め：左下から右上へ
                Case XlDirection.xlToRight + XlDirection.xlUp
                    Sx = .Left
                    Sy = .Top + .Height
                    Ex = .Left + .Width
                    Ey = .Top
                ' 斜め：右下から左上へ
                Case XlDirection.xlToLeft + XlDirection.xlUp
                    Sx = .Left + .Width
                    Sy = .Top + .Height
                    Ex = .Left
                    Ey = .Top
            End Select
        End With

        ' 線矢印を描画。
        Set Arrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Sx, Sy, Ex, Ey)
        With Arrow.Line
            .EndArrowheadStyle = msoArrowheadTriangle
            .ForeColor.ObjectThemeColor = msoThemeColorText1
            .Weight = 0.5
        End With

        Set SetArrow = Arrow
End Function

少し長くなったが、これで四方八方への線矢印描画が可能となる。
それでは、↓ こちらでテストしてみよう。各セルにランダムで、８方向のどれかの線矢印を描画する。

Sub test_5()
    Dim PatternArray(1 To 8) As XlDirection
        PatternArray(1) = xlDown
        PatternArray(2) = xlUp
        PatternArray(3) = xlToRight
        PatternArray(4) = xlToLeft
        PatternArray(5) = xlToRight + xlDown
        PatternArray(6) = xlToLeft + xlDown
        PatternArray(7) = xlToRight + xlUp
        PatternArray(8) = xlToLeft + xlUp
    Dim PatternIndex As Long

    Dim r As Range
        For Each r In Range("A1:F6")
            ' 0～1未満の間で発生する乱数を7倍することで、
            ' 0～7未満の乱数とする。さらに1を加えて、
            ' 1～8未満の乱数としている。
            PatternIndex = Rnd * 7 + 1
            SetArrow r, PatternArray(PatternIndex)
            Application.Wait [NOW() + "00:00:00.1"]
        Next
End Sub