TJシステム設計

<JOB ID="excel正規表現検索(オートシェイプ対応)">
	<!-- excel -->
	<REFERENCE GUID="{00020813-0000-0000-C000-000000000046}" />
	<SCRIPT LANGUAGE="VBScript">
	Option Explicit

    '変数定義
	Dim fname		'ファイル名
	Dim args		'引数
	Dim hitRes
	Dim excel, fso

	fname = ""
	Set args = WScript.Arguments
	hitRes = ""

	'Excelとか開く
	Set excel = WScript.CreateObject("Excel.Application")
	Set fso = WScript.CreateObject("Scripting.FileSystemObject")

	'引数チェック
	If args.length = 0 Then
		'For Double Clicked: File Open Dialog
		fname = excel.GetOpenFileName()
		If fname = False Then
			excel.WindowState = xlMinimized
			WScript.Echo("ファイルを選択してください。")
			WScript.Quit
		End If

	ElseIf args.length = 1 Then
		'For Drug&Drop
		fname = args(0)
		If fso.FolderExists(fname) Then
			WScript.Echo("フォルダは面倒なので、ファイルを指定してください。")
			WScript.Quit
		End If

	Else
		WScript.Echo("ファイルは１つだけにしてくれるとうれしいな。")
		WScript.Quit
	End If


	'検索条件人力
	Dim searchExp, rE
	searchExp = InputBox("検索条件を入力してください。")
	If searchExp = "" Then
		WScript.Echo("何か入れてね")
		WScript.Quit
	End If
	Set rE = CreateObject("VBScript.RegExp")
	rE.Pattern = searchExp	'検索パターン
	rE.IgnoreCase = True	'とりあえず大文字・小文字は区別なし
	rE.Global = True		'文字列全体を検索


	'Workbookを開く
	Dim book1
	Set book1 = excel.Workbooks.Open(fname, true, true)


	'検索実行
	Dim bookName, sheet, rg, rgCur, sp, i
	bookName = book1.Name
	For Each sheet In book1.Worksheets
		hitRes = hitRes + vbCrLf + "--- シート：" + sheet.Name + " ---"

'↓ WinXP SP3 + Excel2003だと、エラーになるかも
		sheet.Activate

		'値セルの検索
		Set rg = sheet.UsedRange.SpecialCells(xlCellTypeConstants)
		For Each rgCur In rg
			If Not IsNull(rgCur.Value) And "" <> rgCur.Value Then
				If rE.Test(rgCur.Value) Then
					hitRes = hitRes + vbCrLf + "  " + rgCur.Address + ":" + vbTab + rgCur.Value
				End If
			End If
		Next

		'数式セルの検索
		rg = Null
		On Error Resume Next
			Set rg = sheet.UsedRange.SpecialCells(xlCellTypeFormulas)
		On Error GoTo 0
		If Not IsNull(rg) Then
			For Each rgCur In rg
				If Not IsNull(rgCur.Formula) And "" <> rgCur.Formula Then
					If rE.Test(rgCur.Formula) Then
						hitRes = hitRes + vbCrLf + "  " + rgCur.Address + ":" + vbTab + rgCur.Formula
					End If
				End If
			Next
		End If

		'オートシェイプの検索
		If 0 < sheet.Shapes.Count Then
			Dim spTxt, idx

			For Each sp In Sheet.Shapes

'オートシェイプ内の文字列取得は、OS、Officeのバージョンによって方法が変わるのかな？
'これだ！ という方法がよく分からなくて、詳しく調べる気もないので、環境毎に都度対応する。

'タイプA（Win7 x64 + Excel2007 では動作した）
				sp.Select
				spTxt = excel.Selection.Characters.Text

'タイプB（胡散臭いやり方。 WinXP SP3 + Excel2003 ではこちらでないと取得できなかった）
'				spTxt = ""
'				On Error Resume Next
'					spTxt = sp.Text
'				On Error GoTo 0
'				If spTxt = "" Then
'					spTxt = sp.AlternativeText
'					idx = InStr(1, spTxt, ": ", 1)
'					If idx > 0 Then
'						spTxt = Right(spTxt, Len(spTxt) - idx)
'					End If
'				End If

				If spTxt <> "" Then
					If rE.Test(spTxt) Then
						hitRes = hitRes + vbCrLf + "  図[" + sp.Name + "]:" + vbTab + Replace(spTxt, vbLf, " ")
					End If
				End If
			Next
		End If
	Next


	'Workbook閉じる
	book1.Close
	Set book1 = Nothing


	'クリップボードへコピーしてダイアログにも表示
	Dim objIE
	Set objIE = WScript.CreateObject("InternetExplorer.Application")
	objIE.Navigate("about:blank")
	objIE.Visible = True 'アクセス許可ダイアログがどこに出るのか分からなくなってしまったので、しょうがなく
	While objIE.Busy
		WScript.Sleep 100
	WEnd
	objIE.Document.parentWindow.clipboardData.setData "text", hitRes
	objIE.Quit
	Set objIE = Nothing

	WScript.Echo("検索結果（クリップボードにもコピーしました）：" + vbCrLf + vbCrLf + hitRes)

	</SCRIPT>
</JOB>