Question

关于编程搜索问题，请教高手？

我想用VB设计一个简单的类似windows搜索功能的软件，除了能实现windows的搜索功能外，关键是能把搜索报告导入到access数据库，请高手赐教，谢谢了！
问题的关键在于：1.可以对word文档内容进行搜索（不打开word）；2.能形成导入到access的搜索报告，字段是：文件名、搜索日期、文件创建日期、修改日期、本次搜索指定的关键词、包含关键字的内容摘要。

Answer 1

模块Option ExplicitDeclare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As LongPublic Const INVALID_HANDLE_VALUE = -1
Public Const MaxLFNPath = 260
Public Const LB_INITSTORAGE = &H1A8
Public Const LB_ADDSTRING = &H180
Public Const WM_SETREDRAW = &HB
Public Const WM_VSCROLL = &H115
Public Const SB_BOTTOM = 7Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End TypeType WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MaxLFNPath
cShortFileName As String * 14
End Type窗体Option Explicit '声明函数
Dim lhwnd As String
Dim dirs, Dir$, files As Integer
Dim isrun As Boolean
Dim WFD As WIN32_FIND_DATA, hItem&, hFile&
Private Sub Form_Load()
lhwnd = List1.hwnd
SendMessage lhwnd, LB_INITSTORAGE, 30000&, ByVal 30000& * 200
End Sub
Private Sub Form_Activate() '设定默认路径
Dir1.Path = App.Path
Drive1.Drive = Left(Dir1.Path, 3)
End Sub
Private Sub Dir1_Change() '选择文件夹
Text1.Text = Dir1.Path & "\"
End Sub
Private Sub Drive1_Change() '选择驱动器
Dir1.Path = Drive1.Drive
End Sub
Private Sub SearchDirs(filepath$)
Dim dircount, i As Integer
Dim dirarray()
DoEvents
If Not isrun Then Exit Sub
hItem& = FindFirstFile(filepath$ & "*.*", WFD) '查找文件
If hItem& <> INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And vbDirectory) Then
If Asc(WFD.cFileName) <> 46 Then
dirs = dirs + 1
If (dircount Mod 10) = 0 Then ReDim Preserve dirarray(dircount + 10)
dircount = dircount + 1
dirarray(dircount) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
End If
Else
files = files + 1
End If
Loop While FindNextFile(hItem&, WFD)
Call FindClose(hItem&) '关闭FindFirstFile
End If
SendMessage lhwnd, WM_SETREDRAW, 0, 0
hFile& = FindFirstFile(filepath$ & Dir$, WFD)
If hFile& <> INVALID_HANDLE_VALUE Then
Do
DoEvents
If Not isrun Then Exit Sub
SendMessage lhwnd, LB_ADDSTRING, 0, _
ByVal filepath$ & Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
Label3.Caption = "文件个数： " & List1.ListCount & " 个"
Loop While FindNextFile(hFile&, WFD)
Call FindClose(hFile&)
End If
SendMessage lhwnd, WM_VSCROLL, SB_BOTTOM, 0
SendMessage lhwnd, WM_SETREDRAW, 1, 0
For i = 1 To dircount: SearchDirs filepath$ & dirarray(i) & "\": Next i
End Sub
Private Sub Text1_Change() '
If Len(Text1.Text) = 4 Then Text1.Text = Left(Text1.Text, 3) '去掉路径中的\
End Sub
Private Sub Command1_Click() '查找文件
On Error Resume Next
If isrun Then: isrun = False: Exit Sub
Dir$ = Text2.Text
MousePointer = 11
isrun = True
List1.Clear '清空列表
If isrun Then Call SearchDirs(Text1.Text) '调用函数查找文件
Label3.Caption = "文件个数： " & List1.ListCount & " 个"
isrun = False
MousePointer = 0
End Sub
Private Sub Command2_Click() '停止查找
isrun = False
MousePointer = 0
End Sub
Private Sub Command3_Click()
End
End Sub