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関連

    「EXCEL VBA 業務自動化 仕事の効率を劇的に上げるノウハウ」レビュー

    ※ 下記レビューはあくまでも個人的な感想です。2015年4…

  2. Office関連

    段落内改行を一括置換するOutlookマクロ

    「段落内改行 置換 Outlook マクロ」といったキーワードでのアク…

  3. アイコン一覧

    Office 365アイコン(imageMso)一覧(S)

    Office 365のデスクトップ版Officeアプリケーション(Wo…

  4. Office関連

    代理人アクセスによって予定を追加するOutlookマクロ

    先日久々にmougの質問に回答しました。マクロを使って、Exc…

  5. Office関連

    Excel 2013 新関数一覧

    「関数一覧(Excel 2010)」と「関数一覧(Excel 2013…

  6. Office関連

    コンテンツコントロールに外部XMLのデータをマップするWordマクロ

    Word 2007で追加された機能「コンテンツコントロール」を使うと外…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP