'################################################### ' 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 & "KWIC表示[" & sSearchString & "]" & vbCr & "") .WriteLine("") .WriteLine("
") .WriteLine(sConStr) .WriteLine("
" & vbCr & "" & vbCr & "") End With objKwicFile.Close sThisFileName = Mid(sFileName, InStrRev(sFileName, "\") + 1, Len(sFileName)) Set objCheckFile = fs.GetFile(sThisFileName) iSize = objCheckFile.Size If objCheckFile.Size =< 440 Then fs.DeleteFile objCheckFile, True End If sTxtStream = "" sConStr = "" sSearchString = ""