如何根据关键字查找日语专利文档，并找到对应的中文文档

ganlechina

Sub search()
    Range("c2:w1000").ClearContents
    Set JPfilePathes = CreateObject("scripting.dictionary")
    Set CNfilePathes = CreateObject("scripting.dictionary")
    startPrintLine = 2
    folderPath = addBackslash(Worksheets("search").Cells(4, 1))
    filePathes = searchAbiscoLog(folderPath)
    For i = 0 To UBound(filePathes)
        If InStr(Split(filePathes(i), "\")(UBound(Split(filePathes(i), "\"))), "-") = 0 Then
            JPfilePathes.Add filePathes(i), ""
        Else
            CNfilePathes.Add filePathes(i), ""
        End If
    Next
    For Each CNfile In CNfilePathes
        Debug.Print CNfile
    Next
    For Each sFName In JPfilePathes
        startPrintLine = searchKeyWords(CNfilePathes, sFName, startPrintLine)
    Next
End Sub

Function searchKeyWords(ByVal CNfilePathes, ByVal sFName, ByVal startPrintLine)
Debug.Print chineseVersionPath
    Set docApp = CreateObject("Word.Application")   '实例化Word对象变量
    docApp.Documents.Open sFName    '打开Word文档
    Keywords = Worksheets("search").Cells(7, 1)
    i = startPrintLine
    With docApp.ActiveDocument
        For Each pg In .Paragraphs  '处理Word中的每一个段落
            str1 = pg.Range.Text    '获取段落中的文本
            If InStr(str1, Keywords) > 0 Then
                Worksheets("search").Cells(i, 3) = sFName
                Worksheets("search").Cells(i, 7) = str1
                Cells(i, 7).Font.Color = vbBlack
                KeywordsStart = InStr(str1, Keywords)
                Cells(i, 7).Characters(KeywordsStart, Len(Keywords)).Font.Color = vbRed
                docName = Split(Split(sFName, "\")(UBound(Split(sFName, "\"))), ".")(0)
                Worksheets("search").Cells(i, 4) = Split(sFName, docName)(0)
                chineseVersionPath = getChineseVersion(docName, CNfilePathes)
                chineseFolder = Left(chineseVersionPath, Len(chineseVersionPath) - Len(Split(chineseVersionPath, "\")(UBound(Split(chineseVersionPath, "\")))))
                Worksheets("search").Cells(i, 5) = chineseVersionPath
                Worksheets("search").Cells(i, 6) = chineseFolder
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 3), Address:=Cells(i, 3).Value, TextToDisplay:=Split(Split(sFName, "\")(UBound(Split(sFName, "\"))), ".")(0)
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 4), Address:=Cells(i, 4).Value, TextToDisplay:="JP Folder"
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 5), Address:=Cells(i, 5).Value, TextToDisplay:=Split(Split(chineseVersionPath, "\")(UBound(Split(chineseVersionPath, "\"))), ".")(0)
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 6), Address:=Cells(i, 6).Value, TextToDisplay:="CN Folder"
                i = i + 1
                startPrintLine = i
            End If
        Next
    End With
    docApp.Quit '退出Word文档
    Set docApp = Nothing    '释放对象变量
'    Debug.Print startPrintLine
    searchKeyWords = startPrintLine
End Function
Function getChineseVersion(ByVal docName, ByVal CNfilePathes)
    Set CNmatchFilePathes = CreateObject("scripting.dictionary")
    If InStr(1, docName, "FCP") > 0 Then
        docNameChinese = docName & "-"
    End If
    If InStr(1, docName, "FS") > 0 Then
        docNameChineseA = docName & "-"
        docNameChineseA = Replace(docNameChineseA, "FS", "C")
        docNameChinesePA = Replace(docNameChineseA, "A", "PA")
    End If
    For Each filePath In CNfilePathes
        If (InStr(1, docName, "FCP") > 0 And InStr(1, filePath, docNameChinese) > 0) Or _
        (InStr(1, docName, "FS") > 0 And (InStr(1, filePath, docNameChineseA) > 0 Or InStr(1, filePath, docNameChinesePA) > 0)) Then
            getChineseVersion = filePath
            CNmatchFilePathes.Add filePath, ""
            Exit For
        End If
    Next
End Function


Function searchAbiscoLog(folderPath)
    Set folderlist = CreateObject("scripting.dictionary")
    Set FileList = CreateObject("scripting.dictionary")
    folderlist.Add folderPath, ""
    Do While folderlist.Count > 0
        For Each FolderName In folderlist.keys
        fname = Dir(FolderName, vbDirectory)
            Do While fname <> ""
                If fname <> ".." And fname <> "." Then
                    If GetAttr(FolderName & fname) And vbDirectory Then 'Here, all of the sub folders are treated as single fname,and the FolderName are changed while add the next sub folder
                            folderlist.Add FolderName & fname & "\", ""
                    Else
                            FileList.Add FolderName & fname, ""
                    End If
                End If
            fname = Dir
            Loop
        folderlist.Remove (FolderName)
        Next
    Loop
    searchAbiscoLog = FileList.keys
End Function

Function addBackslash(folderPath)
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If
    addBackslash = folderPath
End Function