コメントにて以下のご要望をいただきました。
メール本文画面上で選択範囲のみを綺麗に改行したく、本ＨＰの「テキスト形式のメールを指定文字数で折り返すマクロ」
を参考に以下のとおり活用しているのですが、①選択範囲のみではなく全体に適用されてしまう点、②半角文字があると
そこで改行されてしまう点に悩んでいます。修正をお願いできますでしょうか。
よろしくお願いします。
メール本文の選択範囲のみを対象とする場合、Inspector オブジェクトの WordEditor プロパティで取得できる Word のコンポーネントの機能を使用します。
WordEditor プロパティにより本文を編集しているコンポーネントが Word の Document オブジェクトとして取得でき、Document の Application.Selection により選択範囲を表す Selection オブジェクトにより、選択範囲の本文について様々な操作が可能となります。
本文の折り返しをするのであれば、Selection オブジェクトの Text プロパティとして選択範囲の文字列を取得し、折り返した後の文字列を Text プロパティに設定します。
マクロは以下のようになります。
' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub WrapLines()
Const LINE_MAX = 70 ' 折り返しの文字数を指定します
Dim wrdEditor As Object
Dim objSel As Object
Dim strBody As String
Dim strNewBody As String
Dim c As String
Dim pCur As Long
Dim pLf As Long
Dim iLen As Long
' Word Editor オブジェクトを取得
Set wrdEditor = ActiveInspector.WordEditor
' Selection オブジェクトを取得
Set objSel = wrdEditor.Application.Selection
' 選択範囲の文字列を取得
strBody = objSel.Text
' 改行後の本文の初期化
strNewBody = ""
' 処理済みの本文がなくなるまで繰り返し
While Len(strBody) > 0
' 改行位置と 1 行の文字数を初期化
pLf = 0
iLen = 0
' 選択した本文の最後まで
For pCur = 1 To Len(strBody)
' 本文から 1 文字取得
c = Mid(strBody, pCur, 1)
If c = vbCr Then
' 改行ならループ終了
Exit For
ElseIf Asc(c) < 0 Or &H7F < Asc(c) Then
' 全角文字なら文字数は 2
iLen = iLen + 2
' 文字数が制限を超えてなければ改行位置更新
If iLen < LINE_MAX Then
pLf = pCur
End If
ElseIf ("0" <= c And c <= "9") _
Or ("a" <= c And c <= "z") _
Or ("A" <= c And c <= "Z") _
Or InStr("""()[]<>!?.,://@", c) Then
' 半角英数と一部の記号は改行位置を更新しない
iLen = iLen + 1
Else
' 半角記号は改行位置を更新
iLen = iLen + 1
pLf = pCur
End If
' 1 行の文字数が制限以上になったらループ終了
If iLen >= LINE_MAX Then
Exit For
End If
Next
' 改行位置が更新されていなければ、ループ終了時の位置で改行
If pLf = 0 Then
pLf = pCur
End If
' 改行位置までの文字列を新本文に追記
strNewBody = strNewBody & Left(strBody, pLf) & vbCr
' 新本文に追加した文字列は旧本文から削除
If pLf <= Len(strBody) Then
If Mid(strBody, pLf + 1, 1) = vbCr Then
pLf = pLf + 1
End If
strBody = Mid(strBody, pLf + 1)
Else
strBody = ""
End If
Wend
' 改行後の文字列を選択範囲のテキストに設定
objSel.Text = strNewBody
End Sub
Outlook 研究所 