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

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

2012.01.16

ソースコードを番号行付きのテーブルに変換する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 = "ＭＳ ゴシック"
    .NameAscii = "ＭＳ ゴシック"
    .NameOther = "ＭＳ ゴシック"
    .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の処理内容についてについて記事を書きました。