'###################################################
' KWIC 2 (WSH)
' TjSoft-26, Taiju, 2007.8.31
' 【使い方】
' 同じフォルダのテキストファイルから、
' KWICコンコーダンスを作成し、
' 日付をつけたHTMLファイルに書き出す。
'###################################################
Set fs = CreateObject("Scripting.FileSystemObject")
Set objFolder = fs.GetFolder(".")
sFolderName = fs.GetAbsolutePathName(".")
sExtenders = InputBox("半角3文字で指定〔半角スペースで併記可〕", "テキストファイルの拡張子")
aryStrings = Split(sExtenders)
j = UBound(aryStrings)
sSearchString = InputBox("検索する文字を入力", "検索文字列")
flgFileCount = False
For i = 0 to j
sTargetExtender = aryStrings(i)
For Each objFile in objFolder.Files
sObjExtender = Right(LCase(objFile.Name), 3)
If sObjExtender = LCase(sTargetExtender) Then
flgFileCount = True
Set objTextFile = fs.OpenTextFile(objFile)
sTxtStream = objTextFile.ReadAll
iSPos1 = InStr(sTxtStream, sSearchString)
If iSPos1 <> 0 Then
Do
sFileSerial = objFile.Name & ": " & vbCr
'sForCheckFileNameは後で定義。
If sFileSerial <> sForCheckFileName Then
sToWriteFileName = "【" & objFile.Name & " 】
" & vbCr
ElseIf sFileSerial = sForCheckFileName Then
sToWriteFileName = ""
End If
If iSPos1 > 25 Then
sPreStr = Mid(sTxtStream,iSPos1 - 25, 25)
sPreStr = Replace(sPreStr,vbCrLf,"/")
ElseIf iSPos1 < 25 Then
sFillUp1 = String(25 - iSPos1,"*")
'ヒットした文字の直前までを抜き出す。
sPreStr = sFillUp1 & Left(sTxtStream, isPos1 - 1)
sFillUp1 = ""
End If
Set objRegExp = New RegExp
objRegExp.Pattern = "([^、-/-↓A-Za-zぁ-ヶ亜-K ])"
With objRegExp
.IgnoreCase = True
.Global =True
End with
sPreStr = "
" & objRegExp.Replace(sPreStr,"$1" & " ") sPostStr = Mid(sTxtStream,iSPos1 + Len(sSearchString),25) sPostStr = Replace(sPostStr,vbCrLf,"/") If Len(sPostStr) < 25 Then sFillUp2 = String(25 - Len(sPostStr),"*") sPostStr = sPostStr & sFillUp2 End If sPostStr = objRegExp.Replace(sPostStr,"$1" & " ") & "" sForCheckFileName = objFile.Name & ": " & vbCr sConStr = sConStr & sToWriteFileName & Space(4) & sPreStr & Space(2) & "" & sSearchString & "" & Space(2) & sPostStr & vbCr sPreStr = "" sPostStr = "" '+1を入れないと無限ループに陥る。 sTxtStream = Mid(sTxtStream, iSPos1 + 1, Len(sTxtStream)) iSPos1 = Instr(sTxtStream, sSearchString) Loop While iSPos1 <> 0 End If iSPos1 = 0 End If Next Next If flgFileCount = False Then MsgBox("該当するファイルはありませんでした。") End If If Instr(sConStr, sSearchString) = 0 Then MsgBox("検索文字列はありません。") End If sFileName = sFolderName & "\kwic~[" & sSearchString & "](" & Month(Date()) & "・" & Day(Date()) & ").htm" If fs.FileExists(sFileName) Then Set objKwicFile = fs.OpenTextFile(sFileName, 8) Else Set objKwicFile = fs.CreateTextFile(sFileName) End If With objKwicFile .WriteLine("") .WriteLine("" & vbCr & "" & vbCr & "" & vbCr & "