Office関連

ソースコードを番号行付きのテーブルに変換するWordマクロ

Word文書内のソースコードを、他の文書と区別して目立たせたいときに役立つマクロです。

下図のようなソースコードがあったとき、コード部分を選択してマクロを実行すると、

下図のように番号行付きのテーブルへと変換されるので、一目でソースコードだと分かるようになります。


Option Explicit

Public Sub SourceCodeToTable()
'選択しているソースコードを表形式で出力
  Dim tbl As Word.Table
  Dim ln As Long, i As Long
  
  '---------------------------------------------------------------
  'セルの背景色・文字色設定(※ 必要に応じて変更)
  '---------------------------------------------------------------
  Const LineCellBGColor As Long = &H333333 '行番号セルの背景色
  Const LineCellFontColor As Long = &HFFFFFF '行番号セルの文字色
  Const CodeCellBGColor As Long = &HD9D9D9 'コードセルの背景色
  Const CodeCellFontColor As Long = &H0 'コードセルの文字色
  '---------------------------------------------------------------
  
  If ChkCondition = False Then
    MsgBox "ソースコードを選択した状態で実行してください。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
On Error GoTo Err:
  Selection.Cut
  Set tbl = ActiveDocument.Tables.Add(Selection.Range, 1&, 2&)
  
  'フォント設定
  With tbl.Range.Font
    .Size = 10
    .NameFarEast = "MS ゴシック"
    .NameAscii = "MS ゴシック"
    .NameOther = "MS ゴシック"
    .Bold = False
    .Italic = False
    .Underline = wdUnderlineNone
    .UnderlineColor = wdColorAutomatic
    .StrikeThrough = False
    .DoubleStrikeThrough = False
    .Outline = False
    .Emboss = False
    .Shadow = False
    .Hidden = False
    .SmallCaps = False
    .AllCaps = False
    .Color = wdColorAutomatic
    .Engrave = False
    .Superscript = False
    .Subscript = False
  End With
  
  '段落設定
  With tbl.Range.ParagraphFormat
    .LineSpacingRule = wdLineSpaceSingle '行間:1行
    .WordWrap = False '[英単語の途中で改行する(W)]にチェック
  End With
  
  'テーブル設定
  tbl.Borders.Enable = False '罫線をすべて削除
  tbl.Columns(1).PreferredWidthType = wdPreferredWidthPoints
  tbl.Columns(1).PreferredWidth = MillimetersToPoints(12) '行番号列の幅設定
  tbl.Columns(1).Cells.VerticalAlignment = wdCellAlignVerticalTop
  tbl.Columns(1).Cells.Shading.Texture = wdTextureNone
  tbl.Columns(1).Cells.Shading.ForegroundPatternColor = wdColorAutomatic
  tbl.Columns(1).Cells.Shading.BackgroundPatternColor = LineCellBGColor
  tbl.Columns(1).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
  tbl.Columns(1).Cells(1).Range.Font.Color = LineCellFontColor
  tbl.Columns(2).Cells.VerticalAlignment = wdCellAlignVerticalTop
  tbl.Columns(2).Cells.Shading.Texture = wdTextureNone
  tbl.Columns(2).Cells.Shading.ForegroundPatternColor = wdColorAutomatic
  tbl.Columns(2).Cells.Shading.BackgroundPatternColor = CodeCellBGColor
  tbl.Columns(2).Cells(1).Range.Font.Color = CodeCellFontColor
  tbl.Columns(2).PreferredWidthType = wdPreferredWidthAuto
  tbl.AutoFitBehavior wdAutoFitWindow 'ウィンドウサイズに合わせて幅調整
  
  'コード貼り付け
  tbl.Columns(2).Cells(1).Range.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:=wdInLine, DisplayAsIcon:=False
  ln = GetCellLines(tbl)
  If ln = 0& Then Exit Sub
  For i = 1 To ln
    If i <> ln Then
     tbl.Columns(1).Cells(1).Range.InsertAfter i & vbCr
    Else
      tbl.Columns(1).Cells(1).Range.InsertAfter i
    End If
  Next
  Set tbl = Nothing
  Application.ScreenUpdating = True
  Exit Sub

Err:
  MsgBox "処理が失敗しました。", vbCritical + vbSystemModal
  Application.ScreenUpdating = True
End Sub

Private Function ChkCondition() As Boolean
'プロシージャが実行できる状況なのかを確認
  Dim ret As Boolean
  Dim tmp As String
  
  ret = True '初期化
  If Selection.Type <> wdSelectionNormal Then ret = False 'テキストが選択状態にあるかを確認
  '選択文字列が改行と空白のみかどうかを確認
  tmp = Selection.Text
  tmp = Replace$(tmp, vbCr, "")
  tmp = Replace$(tmp, " ", "")
  tmp = Replace$(tmp, " ", "")
  If Len(tmp) < 1 Then ret = False
  ChkCondition = ret
End Function

Private Function GetCellLines(ByVal tbl As Word.Table) As Long
'セルの行数カウント
  Dim ln As Long
  
  ln = 0 '初期化
  tbl.Columns(2).Cells(1).Range.Select
  Selection.StartOf wdCell, wdMove
  Do While Selection.Information(wdWithInTable)
    ln = ln + 1
    Selection.MoveDown wdLine, 1, wdMove
  Loop
  GetCellLines = ln
End Function

テーブルの背景色や文字色、フォント等は好みに応じて適当に変更してください。


2012/01/16 追記:
「GetCellLines」Functionの処理内容についてについて記事を書きました。

2018/7/30 追記:
一部処理を変更した改訂版マクロについて記事を書きました。

関連記事

  1. Office関連

    YouTube動画挿入アドイン for PowerPoint

    前回の記事でPowerPoint 2013でYouTubeの動画が挿入…

  2. Office関連

    各ページを画像に変換するWordマクロ

    Excel MVPの伊藤さんがブログで、WordのPageオブジェクト…

  3. Office アドイン

    [Office用アプリ]「ActiveViewChanged」イベントと「getActiveView…

    v1.1で追加された、ビューが変更された時に発生するイベント「Acti…

  4. Office関連

    クイックアクセスツールバーから履歴を表示するWordテンプレート

    Word MVPの新田さんのブログで「【Word 2013】クイックア…

コメント

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP