Option Explicit
'
' 関数名 : TextDiff
' 返り値 : テキスト差分解析結果2次元配列
' : (正常時)
' : 配列番号=0はタイトル行、配列番号=1以降にテキストデータ
' : 配列(0,0) = "TYPE"
' : 配列(1,0) = "NO."
' : 配列(2,0) = file0PATH
' : 配列(3,0) = "NO."
' : 配列(4,0) = file1PATH
' : 配列(0,1〜) = 変更状態を示す文字列(UPD,ADD,DEL)
' : 配列(1,1〜) = file0の行番号
' : 配列(2,1〜) = file0の各行テキストデータ
' : 配列(3,1〜) = file1の行番号
' : 配列(4,1〜) = file1の各行テキストデータ
' 引き数 : strData0(i) : 変更前テキストデータ
' : strData1(i) : 変更後テキストデータ
' : p1 (i) : 精度微調整パラメータ(一致判定行数)
' : p2 (i) : 精度微調整パラメータ(一致判定文字数)
' : p3 (i) : 精度微調整パラメータ(一致行解析数)
' : file0 (i) : 変更前テキストファイル(file0PATH)
' : file1 (i) : 変更後テキストファイル(file1PATH)
' 機能説明 : テキストファイルを比較し、テキスト差分解析結果を返します
' 備考 : テキスト差分解析ロジックVer5.01
' 著作権 : Copyright(C) 2008-2009 のん All rights reserved
' ---------------------------------------------------------------------------
' 使用条件 : このサイトの内容を使用(流用/改変/転載/等全て)した成果物を不特定
' : 多数に公開/配布する場合は、このサイトを参考にした旨を記述してく
' : ださい。(例)WEBページやReadMeにリンクを貼ってください
' ---------------------------------------------------------------------------
Public Function TextDiff(ByVal strData0 As String, _
ByVal strData1 As String, _
Optional ByVal p1 As Long = 1, _
Optional ByVal p2 As Long = 5, _
Optional ByVal p3 As Long = 10, _
Optional ByVal file0 As String = "file0PATH", _
Optional ByVal file1 As String = "file1PATH") As String()
On Error Resume Next
Dim rtn() As String ' テキスト差分解析結果2次元配列定義
ReDim rtn(4, 0) ' テキスト差分解析結果2次元配列定義
Dim i As Long ' カウンタ(汎用)
Dim j As Long ' カウンタ(汎用)
Dim k As Long ' カウンタ(汎用)
Dim fitCol As Collection ' 最適テキスト差分解析数用のコレクション
Dim fit0 As Long ' 一致行番号(変更前テキストファイル側)
Dim fit1 As Long ' 一致行番号(変更後テキストファイル側)
Dim sumi0 As Long ' 解析済行番号(変更前テキストファイル側)
Dim sumi1 As Long ' 解析済行番号(変更後テキストファイル側)
Dim fdata0() As String ' 変更前テキストデータ配列
Dim fdata1() As String ' 変更後テキストデータ配列
' 変更前テキストデータ配列準備
strData0 = Replace(strData0, vbCrLf, vbLf)
strData0 = Replace(strData0, vbCr, vbLf)
strData0 = vbLf & strData0
fdata0 = Split(strData0, vbLf)
If fdata0(UBound(fdata0)) = "" Then
ReDim Preserve fdata0(UBound(fdata0) - 1)
End If
' 変更後テキストデータ配列
strData1 = Replace(strData1, vbCrLf, vbLf)
strData1 = Replace(strData1, vbCr, vbLf)
strData1 = vbLf & strData1
fdata1 = Split(strData1, vbLf)
If fdata1(UBound(fdata1)) = "" Then
ReDim Preserve fdata1(UBound(fdata1) - 1)
End If
' テキスト差分解析開始
sumi0 = 0
sumi1 = 0
Do
' テキスト差分解析終了判定
If sumi0 >= UBound(fdata0) And sumi1 >= UBound(fdata1) Then
Exit Do
End If
' 一致行解析
Set fitCol = FitAnalysis(fdata0, fdata1, sumi0, sumi1, 1, 5, 10)
' 最適一致行判定
fit0 = UBound(fdata0) + 1
fit1 = UBound(fdata1) + 1
If fitCol.Count = 1 Then
fit0 = fitCol.Item(1)(0)
fit1 = fitCol.Item(1)(1)
Else
Dim maxCnt As Long
maxCnt = 0
' 解析済行に近い一致行を採用
For i = 1 To fitCol.Count
Dim c As Long
c = (fitCol.Item(i)(0) - sumi0) + _
(fitCol.Item(i)(1) - sumi1)
If maxCnt = 0 Or maxCnt > c Then
maxCnt = c
fit0 = fitCol.Item(i)(0)
fit1 = fitCol.Item(i)(1)
End If
Next i
End If
' 変更行をテキスト差分解析結果へ設定
If fit0 - 1 - sumi0 > 0 And fit1 - 1 - sumi1 > 0 Then
' 変更行をテキスト差分解析結果に設定
Dim dfp As Long
Dim smj As Long
dfp = UBound(rtn, 2)
smj = sumi1
For i = sumi0 + 1 To fit0 - 1
For j = smj + 1 To fit1 - 1
If Len(fdata0(i)) > p2 And fdata0(i) = fdata1(j) Then
' 細かく調べると、一致行を発見。。。
For k = smj + 1 To j - 1
' 変更後テキストをテキスト差分解析結果に設定
If UBound(rtn, 2) < dfp + k - smj Then
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
End If
rtn(3, dfp + k - smj) = k
rtn(4, dfp + k - smj) = fdata1(k)
Next k
' 変更前/変更後テキストをテキスト差分解析結果に設定
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
rtn(1, UBound(rtn, 2)) = i
rtn(2, UBound(rtn, 2)) = fdata0(i)
rtn(3, UBound(rtn, 2)) = j
rtn(4, UBound(rtn, 2)) = fdata1(j)
dfp = UBound(rtn, 2)
smj = j
Exit For
End If
Next j
If j > fit1 - 1 Then
' 変更前テキストをテキスト差分解析結果に設定
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
rtn(1, UBound(rtn, 2)) = i
rtn(2, UBound(rtn, 2)) = fdata0(i)
End If
Next i
' 変更後テキストをテキスト差分解析結果に設定
For i = smj + 1 To fit1 - 1
If UBound(rtn, 2) < dfp + i - smj Then
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
End If
rtn(3, dfp + i - smj) = i
rtn(4, dfp + i - smj) = fdata1(i)
Next i
ElseIf fit0 - 1 - sumi0 > 0 And fit1 - 1 - sumi1 <= 0 Then
' 削除行をテキスト差分解析結果に設定
For i = sumi0 + 1 To fit0 - 1
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
rtn(0, UBound(rtn, 2)) = "DEL"
rtn(1, UBound(rtn, 2)) = i
rtn(2, UBound(rtn, 2)) = fdata0(i)
Next i
ElseIf fit0 - 1 - sumi0 <= 0 And fit1 - 1 - sumi1 > 0 Then
' 追加行をテキスト差分解析結果に設定
For i = sumi1 + 1 To fit1 - 1
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
rtn(0, UBound(rtn, 2)) = "ADD"
rtn(3, UBound(rtn, 2)) = i
rtn(4, UBound(rtn, 2)) = fdata1(i)
Next i
End If
' 一致行をテキスト差分解析結果に設定
If fit0 <= UBound(fdata0) And fit1 <= UBound(fdata1) Then
ReDim Preserve rtn(4, UBound(rtn, 2) + 1)
rtn(1, UBound(rtn, 2)) = fit0
rtn(2, UBound(rtn, 2)) = fdata0(fit0)
rtn(3, UBound(rtn, 2)) = fit1
rtn(4, UBound(rtn, 2)) = fdata1(fit1)
End If
' 解析済み行の設定
sumi0 = fit0
sumi1 = fit1
' 画面が固まらないように
DoEvents
Loop
' タイトル行設定
rtn(0, 0) = "TYPE"
rtn(1, 0) = "NO."
rtn(2, 0) = file0
rtn(3, 0) = "NO."
rtn(4, 0) = file1
' TYPE(ADD,DEL,UPD)の設定
For i = 1 To UBound(rtn, 2)
rtn(0, i) = ""
If rtn(1, i) = "" Then
rtn(0, i) = "追加"
ElseIf rtn(3, i) = "" Then
rtn(0, i) = "削除"
ElseIf rtn(2, i) <> rtn(4, i) Then
rtn(0, i) = "変更"
End If
Next i
' リターン
TextDiff = rtn
End Function
' 関数名 : FitAnalysis
' 返り値 : 一致行コレクション
' 引き数 : fdata0(i) : 変更前テキストデータ
' : fdata1(i) : 変更後テキストデータ
' : sumi0 (i) : 解析済行番号(変更前テキストファイル側)
' : sumi1 (i) : 解析済行番号(変更後テキストファイル側)
' : p1 (i) : 精度微調整パラメータ(一致判定行数)
' : p2 (i) : 精度微調整パラメータ(一致判定文字数)
' : p3 (i) : 精度微調整パラメータ(一致行解析数)
' 機能説明 : テキストファイルを比較し一致行コレクションを返します
' 備考 :
' 著作権 : Copyright(C) 2008 - 2009 のん All rights reserved
Private Function FitAnalysis( _
ByRef fdata0() As String, ByRef fdata1() As String, _
ByVal sumi0 As Long, ByVal sumi1 As Long, _
ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long) As Collection
Dim rtn As Collection ' 最適差分解析数用のコレクション
Dim i As Long ' カウンタ(変更前テキストファイル側)
Dim j As Long ' カウンタ(変更後テキストファイル側)
Dim k As Long ' カウンタ(汎用)
Dim diff As Boolean ' 差分発見フラグ
Dim fit(0 To 1) ' 一致行番号
Dim ts As String ' 文字列(汎用)
只今、都合によりサンプルソースの公開を停止しています。
申し訳ございませんが、テキスト差分解析DLL(VB6/VB.NET/C#.NET)でお試しください。
★フォームモジュール(Form1.frm)
Option Explicit
Private Sub Command1_Click()
Dim bytCode() As Byte
Dim intFileNo As Integer
Dim strFpath As String
Dim strData1 As String: strData1 = ""
strFpath = App.Path & "\a.txt"
intFileNo = FreeFile
ReDim bytCode(FileLen(strFpath) - 1) As Byte
Open strFpath For Binary As intFileNo
Get intFileNo, , bytCode
Close
strData1 = StrConv(bytCode, vbUnicode)
Dim strData2 As String: strData2 = ""
strFpath = App.Path & "\b.txt"
intFileNo = FreeFile
ReDim bytCode(FileLen(strFpath) - 1) As Byte
Open strFpath For Binary As intFileNo
Get intFileNo, , bytCode
Close
strData2 = StrConv(bytCode, vbUnicode)
Text1.Text = ""
Dim i As Long
Dim diff() As String
diff = TextDiff(strData1, strData2)
For i = 1 To UBound(diff, 2)
Text1.Text = Text1.Text & _
diff(0, i) & vbTab & _
diff(1, i) & vbTab & _
diff(2, i) & vbTab & _
diff(3, i) & vbTab & _
diff(4, i) & vbCrLf
Next i
End Sub