| |
▼カド さん：
こんばんは。
ちょっと時間が経ってしまったので、見てないかもしれませんが
作ってみました。見ていたら、確認してみて下さい。
標準モジュールに
'===============================================================
Sub main()
Dim flnm
If get_two_flnm(flnm) = True Then '二つの比較するファイル名を得る
ans = file_comp(flnm) 'ファイルの中身の比較
If ans = 0 Then
判定 = "一致しました"
ElseIf ans = 1 Then
判定 = "一致しませんでした"
Else
判定 = "エラー発生のため判定できませんでした"
End If
MsgBox flnm(1) & " と" & vbLf & vbLf & flnm(2) & " は、" & vbLf & vbLf & 判定
End If
End Sub
'===============================================================
Function get_two_flnm(flnm) As Boolean
'Output : flnm(1)とflnm(2)
Dim file_array(1 To 2)
Dim ans
get_two_flnm = True
MsgBox "ファイルを選択して下さい"
For idx = 1 To 2
ans = Application.GetOpenFilename()
If ans <> False Then
file_array(idx) = ans
If idx = 1 Then MsgBox "比較するファイル指定して下さい"
Else
get_two_flnm = False
Exit For
End If
Next idx
If get_two_flnm = True Then
flnm = file_array()
End If
End Function
'===============================================================
Function file_comp(flnm) As Long
'input :flnm(1) flnm(2)
Dim buf As String
Dim bt1() As Byte
Dim bt2() As Byte
Dim flio1 As binio
Dim flio2 As binio
Dim flsz1 As Long
Dim flsz2 As Long
Dim f_offset1 As Long
Dim f_offset2 As Long
file_comp = 0
Set flio1 = New binio
Set flio2 = New binio
If flio1.open_fl(flnm(1), 1024, flsz1) = 0 And _
flio2.open_fl(flnm(2), 1024, flsz2) = 0 Then
If flsz1 = flsz2 Then
Do While flio1.get_fl(bt1(), f_offset1) = 0 And _
flio2.get_fl(bt2(), f_offset2) = 0
For idx = LBound(bt1()) To UBound(bt1())
If bt1(idx) <> bt2(idx) Then
file_comp = 1
End If
Next idx
Loop
Else
file_comp = 1
End If
Else
file_comp = 2
End If
flio1.cls_fl
flio2.cls_fl
Set flio1 = Nothing
Set flio2 = Nothing
End Function
それからクラスモジュール（クラス名はbinioにしました）に、
'===============================================================
Private flno As Long
Private restsz As Long
Private buffer As Long
'===============================================================
Function open_fl(flnm, buffzs As Long, flsize As Long) As Long
On Error Resume Next
flno = FreeFile()
Open flnm For Binary As #flno
open_fl = Err.Number
If open_fl = 0 Then
restsz = LOF(flno)
buffer = buffzs
flsize = restsz
End If
On Error GoTo 0
End Function
'===============================================================
Sub cls_fl()
On Error Resume Next
Close #flno
On Error GoTo 0
End Sub
'===============================================================
Function get_fl(bt() As Byte, g_idx As Long) As Long
' ↑は、ここでは使ってないけどあると便利そうだから
On Error Resume Next
Dim readbyte As Long
If restsz <= 0 Then
get_fl = 1
Else
If restsz >= buffer Then
readbyte = buffer - 1
Else
readbyte = restsz - 1
End If
g_idx = Loc(flno)
ReDim bt(readbyte)
Get #flno, , bt()
get_fl = Err.Number
If get_fl = 0 Then
restsz = restsz - readbyte - 1
End If
End If
On Error GoTo 0
End Function
何回かテストしましたが、それらしく動いていました。
|
|
- 03/10/31(金) 8:49 -
