You Look Too Cool

Sub 段組みをテキスト出力()
    '段数に応じて改行を追加しテキストファイルに出力する。
    Const mojisu1 = 40 '段数が1のとき
    Const mojisu2 = 19 '段数が2のとき
    Const myfilename = "d:\test.txt"
    Dim danrakusu, dansu, mojisu, i
    Dim danraku
    Dim mytext
    '各段落の文字列と段数を取得し、段数に応じて改行を追加する。
    danrakusu = ActiveDocument.Paragraphs.Count
    mytext = ""
    For i = 1 To danrakusu
        danraku = ActiveDocument.Paragraphs(i)
        dansu = danraku.PageSetup.TextColumns.Count
        If (Asc(danraku) <> 12) Then
            If dansu = 1 Then
                mojisu = mojisu1
            Else
                mojisu = mojisu2
            End If
            mytext = mytext & cut(danraku, mojisu)
        End If
    Next i
    '文字列をテキストファイルに出力する。
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Charset = "utf-8"
        .Open
        .WriteText mytext, 1
        .SaveToFile myfilename, 2
        .Close
    End With
End Sub
Function cut(str, num)
    Dim i
    For i = 1 To Len(str)
        cut = cut & Mid(str, i, 1)
        If i Mod num = 0 Then
            cut = cut & Chr(13)
        End If
    Next i
End Function