【Excel】属性をタグに変換(ちょっとだけ改善)

昨日の記事のままだとあまりにお粗末なので、文字列取り出す処理のところだけちょっと改良。

でも美しくないことには変わりない(_ _;)/

Sub addTags()
    Dim ci As Long, cj As Long, length As Long, mode As Long
    Dim chgText As String
    
    length = 0
    mode = 0
    isIndent = 1
    With ActiveCell
        chgText = ""
        ci = 1
        If Application.WorksheetFunction.IsText(.Value) = True Then
            For ci = 1 To .Characters.Count
                If isIndent = 1 Then
                    If .Characters(ci, 1).Text <> ">" And _
                       .Characters(ci, 1).Text <> " " Then
                        isIndent = 0
                    End If
                End If
                If isIndent = 0 Then
                    If .Characters(ci, 1).Font.Strikethrough = True Then
                        mode = 1
                        tagStart = "<del>"
                        tagEnd = "</del>"
                    ElseIf .Characters(ci, 1).Font.ColorIndex = 3 Then ' Red
                        mode = 2
                        tagStart = "<add>"
                        tagEnd = "</add>"
                    End If
                End If
                If mode <> 0 Then
                    If 0 < length Then
'                        chgText = chgText + .Characters(ci-length, length).Text
                        chgText = chgText + getStringFromCharacters(ActiveCell, ci - length, length)
                    End If
                    length = 1
                    For cj = ci + 1 To .Characters.Count
                        If (mode = 1 And .Characters(cj, 1).Font.Strikethrough = True) Or _
                           (mode = 2 And .Characters(cj, 1).Font.ColorIndex = 3) Then
                            length = length + 1
                        Else
                            Exit For
                        End If
                    Next
'                    chgText = chgText + tagStart + .Characters(ci, length).Text + tagEnd
                    chgText = chgText + tagStart + getStringFromCharacters(ActiveCell, ci, length) + tagEnd
                    ci = ci + length - 1
                    length = 0
                    mode = 0
                Else
                    length = length + 1
                End If
            Next
            If 0 < length Then
'                chgText = chgText + .Characters(ci-length, length).Text
                chgText = chgText + getStringFromCharacters(ActiveCell, ci - length, length)
            End If
            .Value = chgText
        End If
    End With
End Sub

Function getStringFromCharacters(tgtCell, start, length) As String
    Dim ci As Long, cnt As Long, locate As Long, rest As Long
    
    getStringFromCharacters = ""
    cnt = length / 256
    locate = start
    With tgtCell
        For ci = 1 To cnt
            getStringFromCharacters = getStringFromCharacters + .Characters(locate, 256).Text
            locate = locate + 256
        Next
        rest = length - 256 * cnt
        If 0 < rest Then
            getStringFromCharacters = getStringFromCharacters + .Characters(locate, rest).Text
        End If
    End With
End Function

【2006.05.26】
注釈と背景色のタグ変換対応＆結果をシート毎にCSV形式で自動保存するように修正→ソースはこちら