はじめに
保守案件やリプレース案件などの仕事をしていると、担当する機能のドキュメントが無い、または、ドキュメントが更新されていない為に仕様がわからない事があります。そんなときは他人が書いたソースコードを読んで仕様を把握しなければなりません。しかし、他人が書いたソースコードはスラスラと簡単に読めるものではありませんし、何度も改修が加えられてプログラムがスパゲティ状態になっている事もあるので、ソースコードを読んで仕様を把握する事は簡単ではありません。
ソースコードを読んで仕様を把握する場合、私はExcelに貼り付けてから読むようにしています。EclipseやVisual Studioなどの統合開発環境はソースコードを読むための便利な機能がたくさんありますが、あえてExcelに貼り付けて読む理由は次の通りです。
- セルの背景色や罫線を利用して重要な変数やメソッドにマークをつけることができる
- セルのコメント機能を利用してコードに対するコメント(メモ)をつけることができる
- 図形を使ったコメント(メモ)をつけることができる
- アウトライン機能を利用して意味のある単位(メソッド、if文、for文など)毎に行を折りたたみ、ソースコードを読みやすくできる
- 文字色や背景色を変更するなどして不要なコード(例:コメント化された古いコード)を目立たないようにすることができる
統合開発環境からコピーしたソースコードを直接Excelに貼り付けると、貼り付けたソースコードはシンタックスハイライトされていません。しかし、コピーしたソースコードを一旦Wordに貼り付け、それを再びコピーしてからExcelに貼り付けるとシンタックスハイライトされた状態で貼り付ける事が出来ます。この操作を自動的に行うマクロを作成したので紹介します。※マクロのソースコードは記事の最後に掲載しています。
使い方
使用上の注意点
- ソースコードに含まれるタブ(\t)は空白に変換してから貼り付けます。その為、コピー元のソースコードと貼り付け先のソースコードは同一ではありません。
- コピー元のエディタのエラー検出機能により、ソースコードに波状の下線が表示されている場合、貼り付け先のソースコードにも下線が付く場合があります。
- コピー元のエディタによっては書式情報をコピーできないものがあります。例えば、Excel VBAのエディタでは出来ません。
- Eclipse上でソースコードをコピーする場合、ソースコードの一部が折りたたまれている状態でコピーすると書式情報が失われます。ソースコードはすべて展開した状態でコピーして下さい。
- Wordがインストールされていない環境では動作しません。
- Excel または Word のバージョンによっては動作しない機能があるかもしれません。動作確認済みのバージョンは Excel 2010, Word 2010, Excel 2013, Word 2013 です。また、動作確認済みのバージョンであってもマクロを実行する環境によっては動作しない場合があるかもしれません。
- しっかりとテストしていませんのでバグがあるかもしれません。^^;
ソースコード
変数名やプロシージャ名、ファンクション名は適当に付けていますので自分好みに変えて下さい。
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
'-------------------------------------------------------------------------------
' タブから空白への置換処理1
'-------------------------------------------------------------------------------
' 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
'-------------------------------------------------------------------------------
' タブから空白への置換処理2
'-------------------------------------------------------------------------------
' 文書内にある全てのタブを空白に置換します。
'-------------------------------------------------------------------------------
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
'-------------------------------------------------------------------------------
' 1行におけるタブから空白への置換処理
'-------------------------------------------------------------------------------
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)
' 1行目の行頭に追加
Call Doc.Range(0, 0).InsertBefore("'")
' 2行目以降の各行の行頭に追加
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