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