以下は、指定したフォルダ内のExcel、Word、PowerPointファイルに対して単語を検索し、検索結果をリストとして表示し、さらにその結果をテキストファイルに履歴として保存するVBAコードです。また、検索結果のファイルにはリンクを付けて、クリックして直接アクセスできるようにしています。
### 改良したVBAコード
```vba
' フォームのボタンがクリックされたときの処理
Private Sub btnSearch_Click()
Dim folderPath As String
Dim searchText As String
' テキストボックスからフォルダパスと検索テキストを取得
folderPath = Me.txtFolderPath.Text
searchText = Me.txtSearchText.Text
If folderPath = "" Or searchText = "" Then
MsgBox "フォルダパスと検索する単語を入力してください。", vbExclamation
Exit Sub
End If
' 検索履歴をクリア
Me.lstResults.Clear
' 検索履歴ファイルの作成
Dim logFile As String
logFile = folderPath & "\search_history.txt"
Open logFile For Append As #1
Print #1, "検索文字列: " & searchText & " | フォルダ: " & folderPath & " | 日付: " & Now
' 検索処理を実行
SearchInExcelFiles folderPath, searchText, Me.lstResults, logFile
SearchInWordFiles folderPath, searchText, Me.lstResults, logFile
SearchInPowerPointFiles folderPath, searchText, Me.lstResults, logFile
Close #1
MsgBox "検索が完了しました。", vbInformation
End Sub
' Excelファイル内で検索
Sub SearchInExcelFiles(folderPath As String, searchText As String, resultsList As MSForms.ListBox, logFile As String)
Dim excelApp As Object
Dim excelBook As Object
Dim sheet As Object
Dim filePath As String
Dim fileSystem As Object
Dim file As Object
Dim found As Boolean
Dim cell As Object
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = False
' 指定したフォルダ内の全Excelファイルをループ
For Each file In fileSystem.GetFolder(folderPath).Files
If LCase(fileSystem.GetExtensionName(file.Name)) = "xlsx" Or LCase(fileSystem.GetExtensionName(file.Name)) = "xls" Then
filePath = file.Path
Set excelBook = excelApp.Workbooks.Open(filePath)
found = False
' シート内のすべてのセルを検索
For Each sheet In excelBook.Sheets
For Each cell In sheet.UsedRange
If InStr(1, cell.Value, searchText, vbTextCompare) > 0 Then
found = True
Exit For
End If
Next cell
If found Then Exit For
Next sheet
If found Then
' 検索結果リストに追加
resultsList.AddItem "Excelファイル: " & filePath
' テキストファイルに記録
Print #1, "Excelファイル: " & filePath
End If
excelBook.Close False
End If
Next file
excelApp.Quit
Set excelApp = Nothing
Set fileSystem = Nothing
End Sub
' Wordファイル内で検索
Sub SearchInWordFiles(folderPath As String, searchText As String, resultsList As MSForms.ListBox, logFile As String)
Dim wordApp As Object
Dim wordDoc As Object
Dim filePath As String
Dim fileSystem As Object
Dim file As Object
Dim found As Boolean
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False
' 指定したフォルダ内の全Wordファイルをループ
For Each file In fileSystem.GetFolder(folderPath).Files
If LCase(fileSystem.GetExtensionName(file.Name)) = "docx" Or LCase(fileSystem.GetExtensionName(file.Name)) = "doc" Then
filePath = file.Path
Set wordDoc = wordApp.Documents.Open(filePath)
found = False
wordApp.Selection.Find.ClearFormatting
With wordApp.Selection.Find
.Text = searchText
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = 1
End With
Do While wordApp.Selection.Find.Execute
found = True
Exit Do
Loop
If found Then
' 検索結果リストに追加
resultsList.AddItem "Wordファイル: " & filePath
' テキストファイルに記録
Print #1, "Wordファイル: " & filePath
End If
wordDoc.Close False
End If
Next file
wordApp.Quit
Set wordApp = Nothing
Set fileSystem = Nothing
End Sub
' PowerPointファイル内で検索
Sub SearchInPowerPointFiles(folderPath As String, searchText As String, resultsList As MSForms.ListBox, logFile As String)
Dim pptApp As Object
Dim pptPresentation As Object
Dim slide As Object
Dim shape As Object
Dim filePath As String
Dim fileSystem As Object
Dim file As Object
Dim found As Boolean
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = msoTrue
' 指定したフォルダ内の全PowerPointファイルをループ
For Each file In fileSystem.GetFolder(folderPath).Files
If LCase(fileSystem.GetExtensionName(file.Name)) = "pptx" Or LCase(fileSystem.GetExtensionName(file.Name)) = "ppt" Then
filePath = file.Path
Set pptPresentation = pptApp.Presentations.Open(filePath)
found = False
' スライド内の全シェイプをチェック
For Each slide In pptPresentation.Slides
For Each shape In slide.Shapes
If shape.HasTextFrame Then
If shape.TextFrame.HasText Then
If InStr(1, shape.TextFrame.TextRange.Text, searchText, vbTextCompare) > 0 Then
found = True
Exit For
End If
End If
End If
Next shape
If found Then Exit For
Next slide
If found Then
' 検索結果リストに追加
resultsList.AddItem "PowerPointファイル: " & filePath
' テキストファイルに記録
Print #1, "PowerPointファイル: " & filePath
End If
pptPresentation.Close
End If
Next file
pptApp.Quit
Set pptApp = Nothing
Set fileSystem = Nothing
End Sub
```
### 機能
1. **フォームを使って検索**: フォームの`txtFolderPath`テキストボックスにフォルダパスを入力し、`txtSearchText`に検索ワードを入力します。
2. **リストに結果を表示**: 検索結果は`lstResults`というリストボックスに表示されます。
3. **検索履歴を保存**: 検索結果は指定フォルダ内に「`search_history.txt`」という名前でテキストファイルに保存され、今後の履歴として確認できます。
4. **結果からファイルを開く**: リストボックスに表示されたファイルパスをクリックすると、そのファイルを開くことができます。
### リストボックスからファイルを開く機能の追加
以下のコードをフォームの`lstResults`に追加することで、リストに表示されたファイルをダブルクリックして開けるようにします。
```vba
Private Sub lstResults_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim selectedFile As String
If lstResults.ListIndex >= 0 Then
selectedFile = lstResults.List(lstResults.ListIndex)
' 検索結果のファイルを開く
Shell "explorer.exe """ & selectedFile & """", vbNormalFocus
End If
End Sub
```
これで、リストボックスに表示された検索結果から直接ファイルを開ける機能が追加されます。
' フォームのボタンがクリックされたときの処理
