シンタックスハイライトされたままソースコードをExcelシートに貼り付けるマクロ

# はじめに

保守案件やリプレース案件などの仕事をしていると、担当する機能のドキュメントが無い、または、ドキュメントが更新されていない為に仕様がわからない事があります。そんなときは他人が書いたソースコードを読んで仕様を把握しなければなりません。しかし、他人が書いたソースコードはスラスラと簡単に読めるものではありませんし、何度も改修が加えられてプログラムがスパゲティ状態になっている事もあるので、ソースコードを読んで仕様を把握する事は簡単ではありません。

ソースコードを読んで仕様を把握する場合、私はExcelに貼り付けてから読むようにしています。EclipseやVisual Studioなどの統合開発環境はソースコードを読むための便利な機能がたくさんありますが、あえてExcelに貼り付けて読む理由は次の通りです。

* セルの背景色や罫線を利用して重要な変数やメソッドにマークをつけることができる
* セルのコメント機能を利用してコードに対するコメント（メモ）をつけることができる
* 図形を使ったコメント（メモ）をつけることができる
* アウトライン機能を利用して意味のある単位（メソッド、if文、for文など）毎に行を折りたたみ、ソースコードを読みやすくできる
* 文字色や背景色を変更するなどして不要なコード（例：コメント化された古いコード）を目立たないようにすることができる

統合開発環境からコピーしたソースコードを直接Excelに貼り付けると、貼り付けたソースコードはシンタックスハイライトされていません。しかし、コピーしたソースコードを一旦Wordに貼り付け、それを再びコピーしてからExcelに貼り付けるとシンタックスハイライトされた状態で貼り付ける事が出来ます。この操作を自動的に行うマクロを作成したので紹介します。※マクロのソースコードは記事の最後に掲載しています。

# 使い方

1. ソースコードを選択してコピーする
![ps3.png](https://qiita-image-store.s3.amazonaws.com/0/85927/6d06f837-8669-128e-3c69-d73829874674.png)

2. 貼り付け先のセルを選択してマクロを実行する
![ps5.png](https://qiita-image-store.s3.amazonaws.com/0/85927/a3ffc8f6-57a6-6e04-375f-26f4ae1d16ac.png)

実行結果
![ps6.png](https://qiita-image-store.s3.amazonaws.com/0/85927/edfdf9e0-4c78-774f-29e5-1e2045b20a3f.png)

# 使用上の注意点

* ソースコードに含まれるタブ(\t)は空白に変換してから貼り付けます。その為、コピー元のソースコードと貼り付け先のソースコードは同一ではありません。
* コピー元のエディタのエラー検出機能により、ソースコードに波状の下線が表示されている場合、貼り付け先のソースコードにも下線が付く場合があります。
* コピー元のエディタによっては書式情報をコピーできないものがあります。例えば、Excel VBAのエディタでは出来ません。
* Eclipse上でソースコードをコピーする場合、ソースコードの一部が折りたたまれている状態でコピーすると書式情報が失われます。ソースコードはすべて展開した状態でコピーして下さい。
* Wordがインストールされていない環境では動作しません。
* Excel または Word のバージョンによっては動作しない機能があるかもしれません。動作確認済みのバージョンは Excel 2010, Word 2010, Excel 2013, Word 2013 です。また、動作確認済みのバージョンであってもマクロを実行する環境によっては動作しない場合があるかもしれません。
* しっかりとテストしていませんのでバグがあるかもしれません。^^;

# ソースコード

変数名やプロシージャ名、ファンクション名は適当に付けていますので自分好みに変えて下さい。

```vbnet
Option Explicit

'-------------------------------------------------------------------------------
' マクロのエントリ
'-------------------------------------------------------------------------------
Public Sub 書式付貼付()

    If ActiveCell Is Nothing Then
        Call MsgBox("貼り付け先のセルを選択して下さい。", vbExclamation Or vbOKOnly, "書式付貼付")
    End If

    Call PasteViaWord(ActiveCell, 4)

End Sub

'-------------------------------------------------------------------------------
' Word経由による貼り付け
'-------------------------------------------------------------------------------
Private Sub PasteViaWord(Cell As Excel.Range, Optional TabSize As Long = 0)

    Dim WordApp As Object
    Dim QuitFlag As Boolean
    Dim Doc As Object

    ' Word.Applicationオブジェクトの取得
    Set WordApp = GetWordApplication(QuitFlag)

    ' Word文書の新規作成
    Set Doc = WordApp.Documents.Add(Visible:=False)

    ' Word文書上に貼り付け
    Call Doc.Range.PasteAndFormat(16)

    ' タブを空白に変換
    If TabSize > 0 Then
        Call TabsToSpaces1(Doc, TabSize)
        Call TabsToSpaces2(Doc, TabSize)
    End If

    ' 行頭に'(アポストロフィー)を追加
    Call PrependApostrophe(Doc)

    ' Excelシート上に貼り付け
    Call Doc.Range.Copy
    Call Cell.Parent.Activate
    Call Cell.Select
    Call Cell.Parent.Paste

    ' セルの再評価
    If TypeOf Selection Is Excel.Range Then
        Call DoF2Enter(Selection)
    End If

    ' Word文書を閉じる
    Call Doc.Close(SaveChanges:=False)

    ' 当マクロで起動したWordの場合はWordを終了させる
    If QuitFlag Then
        Call WordApp.Quit(SaveChanges:=False)
    End If

End Sub

'-------------------------------------------------------------------------------
' Word.Applicationオブジェクトの取得
'-------------------------------------------------------------------------------
' Wordが既に起動している場合はそのWordのApplicationオブジェクトを取得します。
' Wordが起動していない場合はWordを起動してApplicationオブジェクトを取得します。
'-------------------------------------------------------------------------------
Private Function GetWordApplication(ByRef QuitFlag As Boolean) As Object

    On Error Resume Next

    Dim App As Object

    ' 既に起動しているWordのApplicationオブジェクトを取得する
    Set App = GetObject(, "Word.Application")

    If App Is Nothing Then
        On Error GoTo 0
        ' 既に起動しているWordのApplicationオブジェクトが無ければ
        ' Wordを起動してApplicationオブジェクトを取得する
        Set App = CreateObject("Word.Application")
        QuitFlag = True
    Else
        QuitFlag = False
    End If

    Set GetWordApplication = App

End Function

'-------------------------------------------------------------------------------
' タブから空白への置換処理１
'-------------------------------------------------------------------------------
' Wordの置換機能を利用し、行頭から連続するタブを空白に置換します。
' この処理で置換できなかったタブは TabsToSpaces2 で置換します。
'-------------------------------------------------------------------------------
Private Sub TabsToSpaces1(Doc As Object, Optional TabSize As Long = 4)

    Dim i As Long
    Dim ReplaceWith As String
    Dim FindText As String
    Dim DocRange As Object

    i = 0
    ReplaceWith = "\1" & String(TabSize, " ")
    Set DocRange = Doc.Range(0, 0)

    Do
        i = i + 1
        If i = 1 Then
            FindText = "(^13)^t"
        Else
            FindText = "(^13^32{" & (TabSize * (i - 1)) & "})^t"
        End If
    Loop While DocRange.Find.Execute( _
                                FindText:=FindText, _
                                MatchWildcards:=True, _
                                ReplaceWith:=ReplaceWith, _
                                Replace:=2 _
                            )

End Sub

'-------------------------------------------------------------------------------
' タブから空白への置換処理２
'-------------------------------------------------------------------------------
' 文書内にある全てのタブを空白に置換します。
'-------------------------------------------------------------------------------
Private Sub TabsToSpaces2(Doc As Object, Optional TabSize As Long = 4)

    Dim DocRange As Object
    Set DocRange = Doc.Range(0, 0)

    DocRange.Find.ClearAllFuzzyOptions
    DocRange.Find.ClearFormatting
    DocRange.Find.ClearHitHighlight

    ' タブを検索する
    Do While DocRange.Find.Execute(FindText:="^t", MatchWildcards:=False, Forward:=True)
        ' 範囲をタブが見つかった行の行全体へ変更
        Call ExtendToEntireRow(DocRange)
        ' タブを空白に置換
        Call Tab2Space(DocRange, TabSize)
        ' 範囲の解除
        Call DocRange.Collapse(0)
    Loop

End Sub

'-------------------------------------------------------------------------------
' 行全体への範囲の変更（行頭から行末までの範囲の拡張）
'-------------------------------------------------------------------------------
Private Sub ExtendToEntireRow(DocRange As Object)

    With DocRange
        ' 範囲の開始位置を行頭へ変更する
        If .MoveStartUntil(vbCr & vbLf & vbVerticalTab, &HC0000001) = 0 Then
            Call .StartOf(6, 1)
        End If
        ' 範囲の終了位置を行末へ変更する
        If .MoveEndUntil(vbCr & vbLf & vbVerticalTab, &H3FFFFFFF) = 0 Then
            Call .EndOf(6, 1)
        End If
    End With

End Sub

'-------------------------------------------------------------------------------
' １行におけるタブから空白への置換処理
'-------------------------------------------------------------------------------
Private Sub Tab2Space(LineRange As Object, Optional TabSize = 4)

    Dim CurrPos As Long, PrevPos As Long, FindPos As Long
    Dim Offset As Long, SpcSize As Long
    Dim LineStr As String, SubStr As String

    LineStr = LineRange.Text
    CurrPos = PrevPos = Offset = 0
    FindPos = InStr(PrevPos + 1, LineStr, vbTab)

    Do While FindPos > 0
        SubStr = Mid(LineStr, PrevPos + 1, FindPos - PrevPos - 1)
        CurrPos = CurrPos + StringWidth(SubStr)
        SpcSize = TabSize - (CurrPos Mod TabSize)
        CurrPos = CurrPos + SpcSize

        LineRange.Characters(FindPos + Offset).Text = Space(SpcSize)
        Offset = Offset + SpcSize - 1

        PrevPos = FindPos
        FindPos = InStr(PrevPos + 1, LineStr, vbTab)
    Loop

End Sub

'-------------------------------------------------------------------------------
' 文字列の幅(半角文字は1、全角文字は2)の取得
'-------------------------------------------------------------------------------
Private Function StringWidth(Target As String) As Long

    StringWidth = LenB(StrConv(Target, vbFromUnicode))

End Function

'-------------------------------------------------------------------------------
' 行頭に'(アポストロフィー)を追加
'-------------------------------------------------------------------------------
Private Sub PrependApostrophe(Doc As Object)

    ' １行目の行頭に追加
    Call Doc.Range(0, 0).InsertBefore("'")

    ' ２行目以降の各行の行頭に追加
    Call Doc.Range(0, 0).Find.Execute( _
                                    FindText:="^13([!^13])", _
                                    MatchWildcards:=True, _
                                    ReplaceWith:="^p^39\1", _
                                    Replace:=2 _
                                )

End Sub

'-------------------------------------------------------------------------------
' セルの再評価
'-------------------------------------------------------------------------------
' 各セルに対してF2＋Enterキー操作と同様の機能を実行する。
' セルに貼り付けた直後は行頭に加えた'(アポストロフィー)が表示されたまま
' になっているので、セルを再評価(?)することで行頭の'(アポストロフィー)が
' 表示させないようにする。
'-------------------------------------------------------------------------------
Private Sub DoF2Enter(CellRange As Excel.Range)

    'On Error Resume Next

    Dim Cell As Excel.Range

    For Each Cell In CellRange
        Call Cell.Characters(Cell.Characters.Count + 1).Insert("")
    Next

End Sub

```