Attribute VB_Name = "Kesentoshape"
''罫線を図形（シェイプ）に変更するモジュール

Private Type tLineFormat
    BeginX As Double
    BeginY As Double
    EndX As Double
    EndY As Double
    Style As Long
    Dash As Long
    Weight As Single
    Color As Long
End Type

Sub Border2ShapeEx()
    Dim TargetArea As Range
    Dim r As Range
    Dim rn As Long
    Dim cn As Long
    Dim LineFormat As tLineFormat
    Dim LineID As Integer
     
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Areas.Count > 1 Then
        MsgBox "複数の範囲を選択していると実行できません", vbCritical
        Exit Sub
    End If
    Set TargetArea = Intersect(Selection, ActiveSheet.UsedRange)
    If TargetArea Is Nothing Then Exit Sub
    With TargetArea
     
        '上横線変換
        For rn = 1 To .Rows.Count
            ChangeLineH TargetArea, xlEdgeTop, LineFormat, rn
        Next
     
        '下端横線変換
        ChangeLineH TargetArea, xlEdgeBottom, LineFormat, .Rows.Count

        '左縦線変換
        For cn = 1 To .Columns.Count
            ChangeLineV TargetArea, xlEdgeLeft, LineFormat, cn
        Next
             
        '右端縦線変換
        ChangeLineV TargetArea, xlEdgeRight, LineFormat, .Columns.Count
     
        '斜線変換
        For Each r In TargetArea
            With r
                 
                '右上がり
                LineID = GetLineIndex(r, xlDiagonalUp, LineFormat)
                If LineID > 1 Then
                    LineFormat.BeginX = .Left
                    LineFormat.BeginY = .Top + .Height
                    LineFormat.EndX = .Left + .Width
                    LineFormat.EndY = .Top
                    DrawLine LineFormat
                End If
                 
                '右下がり
                LineID = GetLineIndex(r, xlDiagonalDown, LineFormat)
                If LineID > 1 Then
                    LineFormat.BeginX = .Left
                    LineFormat.BeginY = .Top
                    LineFormat.EndX = .Left + .Width
                    LineFormat.EndY = .Top + .Height
                    DrawLine LineFormat
                End If
            End With
        Next
         
        '罫線削除
        .Borders(xlDiagonalUp).LineStyle = xlLineStyleNone
        .Borders(xlDiagonalDown).LineStyle = xlLineStyleNone
        .Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
        .Borders(xlEdgeTop).LineStyle = xlLineStyleNone
        .Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
        .Borders(xlEdgeRight).LineStyle = xlLineStyleNone
        .Borders(xlInsideVertical).LineStyle = xlLineStyleNone
        .Borders(xlInsideHorizontal).LineStyle = xlLineStyleNone
        .Select
    End With
    Set r = Nothing
    Set TargetArea = Nothing
End Sub

Private Function GetLineIndex(ByRef Target As Range, _
                              ByVal BorderID As Long, _
                              ByRef LineFormat As tLineFormat) As Integer
    With Target.Borders(BorderID)
        LineFormat.Color = .Color
        If .LineStyle = xlLineStyleNone Then
            GetLineIndex = 1
            LineFormat.Style = 0
            LineFormat.Dash = 0
            LineFormat.Weight = 0
            LineFormat.Color = -1
        ElseIf .LineStyle = xlContinuous And _
               .Weight = xlHairline Then
            GetLineIndex = 2
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineSolid
            LineFormat.Weight = 0.25
        ElseIf .LineStyle = xlDot Then
            GetLineIndex = 3
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineRoundDot
            LineFormat.Weight = 0.5
        ElseIf .LineStyle = xlDashDotDot And _
               .Weight = xlThin Then
            GetLineIndex = 4
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineDashDotDot
            LineFormat.Weight = 0.5
        ElseIf .LineStyle = xlDashDot And _
               .Weight = xlThin Then
            GetLineIndex = 5
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineLongDashDot
            LineFormat.Weight = 0.5
        ElseIf .LineStyle = xlDash And _
               .Weight = xlThin Then
            GetLineIndex = 6
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineSquareDot
            LineFormat.Weight = 0.5
        ElseIf .LineStyle = xlContinuous And _
               .Weight = xlThin Then
            GetLineIndex = 7
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineSolid
            LineFormat.Weight = 0.75
        ElseIf .LineStyle = xlDashDotDot And _
               .Weight = xlMedium Then
            GetLineIndex = 8
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineDashDotDot
            LineFormat.Weight = 1.25
        ElseIf .LineStyle = xlSlantDashDot Then
            GetLineIndex = 9
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineLongDashDot
            LineFormat.Weight = 1.5
        ElseIf .LineStyle = xlDashDot And _
               .Weight = xlMedium Then
            GetLineIndex = 10
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineLongDashDot
            LineFormat.Weight = 1.25
        ElseIf .LineStyle = xlDash And _
               .Weight = xlMedium Then
            GetLineIndex = 11
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineDash
            LineFormat.Weight = 1.25
        ElseIf .LineStyle = xlContinuous And _
               .Weight = xlMedium Then
            GetLineIndex = 12
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineSolid
            LineFormat.Weight = 1.25
        ElseIf .LineStyle = xlContinuous And _
               .Weight = xlThick Then
            GetLineIndex = 13
            LineFormat.Style = msoLineSingle
            LineFormat.Dash = msoLineSolid
            LineFormat.Weight = 2
        ElseIf .LineStyle = xlDouble Then
            GetLineIndex = 14
            LineFormat.Style = msoLineThinThin
            LineFormat.Dash = msoLineSolid
            LineFormat.Weight = 3
        Else
            GetLineIndex = 0
            LineFormat.Style = 0
            LineFormat.Dash = 0
            LineFormat.Weight = 0
            LineFormat.Color = -1
        End If
    End With
End Function

Private Sub DrawLine(ByRef LineFormat As tLineFormat)
    With ActiveSheet.Shapes.AddLine(LineFormat.BeginX, LineFormat.BeginY, _
                                    LineFormat.EndX, LineFormat.EndY).Line
        .Style = LineFormat.Style
        .DashStyle = LineFormat.Dash
        .Weight = LineFormat.Weight
        .ForeColor.RGB = LineFormat.Color
    End With
End Sub

Private Sub ChangeLineH(ByRef TargetArea As Range, ByVal BorderID As Long, _
                        ByRef LineFormat As tLineFormat, ByVal rn As Long)
    Dim NextFormat As tLineFormat
    Dim LineID As Integer
    Dim NextID As Integer
    Dim StartPos As Long
    Dim cn As Long
    Dim r As Range
        
    With TargetArea
        For StartPos = 1 To .Columns.Count
            Set r = .Cells(rn, StartPos)
            LineID = GetLineIndex(r, BorderID, LineFormat)
            If LineID > 1 Then
                With LineFormat
                    .BeginX = r.Left
                    .BeginY = r.Top
                    If BorderID = xlEdgeBottom Then .BeginY = .BeginY + r.Height
                    .EndY = .BeginY
                End With
                Exit For
            End If
        Next
        For cn = StartPos To .Columns.Count
            Set r = .Cells(rn, cn)
            LineID = GetLineIndex(r, BorderID, LineFormat)
            If cn = .Columns.Count Then
                NextID = 99
                NextFormat.Color = -1
            Else
                NextID = GetLineIndex(r.Offset(0, 1), BorderID, NextFormat)
            End If
            With LineFormat
                If LineID <> NextID Or .Color <> NextFormat.Color Then
                    .EndX = r.Left + r.Width
                    If LineID > 1 Then DrawLine LineFormat
                    .BeginX = .EndX
                End If
            End With
        Next
    End With
End Sub

Private Sub ChangeLineV(ByRef TargetArea As Range, ByVal BorderID As Long, _
                        ByRef LineFormat As tLineFormat, ByVal cn As Long)
    Dim NextFormat As tLineFormat
    Dim LineID As Integer
    Dim NextID As Integer
    Dim StartPos As Long
    Dim rn As Long
    Dim r As Range
        
    With TargetArea
        For StartPos = 1 To .Rows.Count
            Set r = .Cells(StartPos, cn)
            LineID = GetLineIndex(r, BorderID, LineFormat)
            If LineID > 1 Then
                With LineFormat
                    .BeginX = r.Left
                    .BeginY = r.Top
                    If BorderID = xlEdgeRight Then .BeginX = .BeginX + r.Width
                    .EndX = .BeginX
                End With
                Exit For
            End If
        Next
        For rn = StartPos To .Rows.Count
            Set r = .Cells(rn, cn)
            LineID = GetLineIndex(r, BorderID, LineFormat)
            If rn = .Rows.Count Then
                NextID = 99
                NextFormat.Color = -1
            Else
                NextID = GetLineIndex(r.Offset(1, 0), BorderID, NextFormat)
            End If
            With LineFormat
                If LineID <> NextID Or .Color <> NextFormat.Color Then
                    .EndY = r.Top + r.Height
                    If LineID > 1 Then DrawLine LineFormat
                    .BeginY = .EndY
                End If
            End With
        Next
    End With
End Sub