AW: VBA-Excel-Search-Engine
06.03.2015 16:07:37
Nepumuk
Hallo,
ja das geht. Ist ziemlich heftig (musst du dir aber noch anpassen):
' **********************************************************************
' Modul: Version_32_Bit Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'von Isabelle
Private Declare Function FindExecutableA Lib "shell32.dll" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare Function GetShortPathNameA Lib "kernel32.dll" ( _
ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
Private Declare Function ShellExecuteA Lib "shell32.dll" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Declare Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function EnumChildWindows Lib "user32.dll" ( _
ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Private Declare Function GetWindowTextA Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function GetWindowTextLengthA Lib "user32.dll" ( _
ByVal hwnd As Long) As Long
Private Const MAX_PATH = 260
Private Const SW_MAXIMIZE = 3
Private Const WM_CLOSE = &H10
Private Const GC_CLASSNAME_ADOBEPDF = "AcrobatSDIWindow"
Private Const GC_CLASSNAME_ADOBESEARCH = "AVL_AVWindow"
Private Const TEXT_SCROLLVIEW = "AVScrollView"
Private Const TEXT_TREEVIEW = "AVTreeViewClass"
Private Const TEXT_NODE = "AVTreeNodeSimpleView"
Private lstrWindowText As String
Private llngChildHwnd As Long
Public Sub Search_in_PDF()
Const FOLDER_PATH = "D:\Eigene Dateien\Eigene eBooks\" 'Ordner in dem sich die PDF's befinden
Dim strFileName As String, strExecutable As String
Dim strFilePath As String, strSearchText As String
Dim strParameter As String, strDirectory As String
Dim strTemp As String * MAX_PATH, strPath As String * MAX_PATH
Dim lngReturn As Long, lngHwndPDF As Long
Dim lngHwndSearch As Long, lngTempHwnd As Long
Dim lngRow As Long
strSearchText = InputBox("Bitte Suchbegriff eingeben.", "Eingabe")
If StrPtr(strSearchText) = 0 Then Exit Sub
strSearchText = Trim$(strSearchText)
If strSearchText = vbNullString Then Exit Sub
Call Close_PDF_Reader
Columns(1).Clear
strFileName = Dir$(FOLDER_PATH & "*.pdf")
Do Until strFileName = vbNullString
If strExecutable = vbNullString Then
lngReturn = FindExecutableA(FOLDER_PATH & strFileName, vbNullString, strTemp)
If lngReturn > 32 Then
strExecutable = Left$(strTemp, InStr(strTemp & vbNullChar, vbNullChar) - 1)
Else
MsgBox "Kein Programm zum Öffnen von PDF's gefunden.", _
vbCritical, "Programmabbruch"
Exit Sub
End If
lngReturn = GetShortPathNameA(strExecutable, strPath, MAX_PATH)
strExecutable = Left$(strPath, lngReturn)
strDirectory = Left$(strExecutable, 3)
End If
lngReturn = GetShortPathNameA(FOLDER_PATH & strFileName, strPath, MAX_PATH)
strFilePath = Left$(strPath, lngReturn)
strParameter = "/A ""search=" & strSearchText & """ " & strFilePath
lngReturn = ShellExecuteA(Application.hwnd, "open", strExecutable, _
strParameter, strDirectory, SW_MAXIMIZE)
If lngReturn <= 32 Then
MsgBox ShellExecuteErrMessage(lngReturn), vbCritical, "Programmabbruch"
Exit Sub
Else
If CaptureAdobeWindow(lngHwndPDF) Then
lngHwndSearch = FindWindowA(GC_CLASSNAME_ADOBESEARCH, vbNullString)
If lngHwndSearch <> 0 Then
lstrWindowText = TEXT_SCROLLVIEW
llngChildHwnd = 0
Call EnumChildWindows(lngHwndSearch, AddressOf SearchChildWindow, ByVal 0&)
If llngChildHwnd <> 0 Then
lstrWindowText = TEXT_TREEVIEW
lngTempHwnd = llngChildHwnd
llngChildHwnd = 0
Call EnumChildWindows(lngTempHwnd, AddressOf SearchChildWindow, ByVal 0&)
If llngChildHwnd <> 0 Then
lstrWindowText = TEXT_NODE
lngTempHwnd = llngChildHwnd
llngChildHwnd = 0
Call EnumChildWindows(lngTempHwnd, AddressOf SearchChildWindow, ByVal 0&)
If llngChildHwnd <> 0 Then
lngRow = lngRow + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(lngRow, 1), Address:= _
FOLDER_PATH & strFileName, TextToDisplay:=strFileName
End If
Else
MsgBox "TreeView-Klasse im Suchenfenster nicht gefunden.", _
vbCritical, "Programmabbruch"
Exit Sub
End If
Else
MsgBox "ScrollView-Klasse im Suchenfenster nicht gefunden.", _
vbCritical, "Programmabbruch"
Exit Sub
End If
Else
MsgBox "Suchfenster des Adobe-Readers nicht gefunden.", _
vbCritical, "Programmabbruch"
Exit Sub
End If
Call PostMessageA(lngHwndPDF, WM_CLOSE, 0&, 0&)
Else
MsgBox "Fenster des Adobe-Readers nicht gefunden.", _
vbCritical, "Programmabbruch"
Exit Sub
End If
End If
strFileName = Dir$
Loop
Call Close_PDF_Reader
MsgBox "Die Suche nach ''" & strSearchText & _
"'' ist abgeschlossen.", vbInformation, "Information"
End Sub
Private Function CaptureAdobeWindow( _
ByRef prlngHwndPDF As Long) As Boolean
Dim lngSumActivity As Long, lngWaitForWindow As Long
Dim lngWaitForProcess As Long, lngCounter As Long
Dim objProcess As Object, objItem As Object
For lngWaitForWindow = 1 To 100
prlngHwndPDF = FindWindowA(GC_CLASSNAME_ADOBEPDF, vbNullString)
If prlngHwndPDF <> 0 Then
For lngWaitForProcess = 1 To 100
Set objProcess = GetObject("winmgmts:").InstancesOf( _
"Win32_PerfFormattedData_PerfProc_Process WHERE Name LIKE 'AcroRd%'")
For Each objItem In objProcess
lngSumActivity = lngSumActivity + objItem.PercentPrivilegedTime + _
objItem.PercentProcessorTime + objItem.PercentUserTime
Next
If lngSumActivity = 0 Then
lngCounter = lngCounter + 1
If lngCounter = 4 Then
CaptureAdobeWindow = True
Exit For
End If
End If
lngSumActivity = 0
Call Sleep(500)
Next
Exit For
End If
Call Sleep(500)
Next
End Function
Private Function SearchChildWindow( _
ByVal pvlngHwnd As Long, _
ByVal pvlngParameter As Long) As Long
Dim strText As String
strText = Space$(GetWindowTextLengthA(pvlngHwnd) + 1)
Call GetWindowTextA(pvlngHwnd, strText, Len(strText))
strText = Left$(strText, Len(strText) - 1)
If strText = lstrWindowText Then
llngChildHwnd = pvlngHwnd
SearchChildWindow = 0
Else
SearchChildWindow = 1
End If
End Function
Private Function ShellExecuteErrMessage( _
ByVal pvlngReturn As Long) As String
Select Case pvlngReturn
Case 0: ShellExecuteErrMessage = _
"Zuwenig Speicher, ausführbare Datei war " & _
"zerstört, Relokationswerte waren ungültig"
Case 2: ShellExecuteErrMessage = _
"Datei wurde nicht gefunden."
Case 3: ShellExecuteErrMessage = _
"Verzeichnis wurde nicht gefunden."
Case 5: ShellExecuteErrMessage = _
"Fehler beim gemeinsamen Zugriff auf eine Datei im Netz oder " & vbLf & _
"Fehler beim Zugriff auf eine gesperrte Datei im Netz."
Case 6: ShellExecuteErrMessage = _
"Bibliothek forderte separate Datensegmente für jede Task an."
Case 8: ShellExecuteErrMessage = _
"Zuwenig Speicher, um die Anwendung zu starten."
Case 10: ShellExecuteErrMessage = "Falsche Windows-Version."
Case 11: ShellExecuteErrMessage = _
"Ungültige ausführbare Datei. Entweder keine" & vbLf & _
"Windows-Anwendung oder Fehler in der EXE-Datei."
Case 12: ShellExecuteErrMessage = _
"Anwendung für ein anderes Betriebssystem."
Case 13: ShellExecuteErrMessage = "Anwendung für MS-DOS 4.0."
Case 14: ShellExecuteErrMessage = "Typ der ausführbaren Datei unbekannt."
Case 15: ShellExecuteErrMessage = _
"Versuch, eine Real-Mode-Anwendung " & _
"(für eine frühere Windows-Version) zu laden."
Case 16: ShellExecuteErrMessage = _
"Versuch, eine zweite Instanz einer ausführbaren Datei mit mehreren " & vbLf & _
"Datensegmenten die nicht als nur lesbar gekennzeichnet waren, zu laden."
Case 19: ShellExecuteErrMessage = _
"Versuch, eine komprimierte ausführbare Datei zu laden." & vbLf & _
"Die Datei muß dekomprimiert werden, bevor sie geladen werden kann."
Case 20: ShellExecuteErrMessage = _
"Ungültige dynamische Linkbibliothek (DLL)." & vbLf & "Eine der DLLs, " & vbLf & _
"die benötigt wurde, um die Anwendung auszuführen, war beschädigt."
Case Else: ShellExecuteErrMessage = _
"Ein Unbekannter Fehler ist aufgetreten. (" & CStr(pvlngReturn) & ")"
End Select
End Function
Private Sub Close_PDF_Reader()
Dim objWMI As Object, objProcessList As Object, objProcess As Object
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objProcessList = objWMI.ExecQuery("Select * from Win32_Process " & _
"WHERE Name LIKE 'AcroRd%'")
On Error Resume Next
For Each objProcess In objProcessList
Call objProcess.Terminate(0)
Next
End Sub
Gruß
Nepumuk