|
|
|
|
|
|
Public Enum bfErrorConstants
bfErrFileAlreadyOpen = vbObjectError + 20000
bfErrInvalidObject = vbObjectError + 20001
bfErrFileNotFound = vbObjectError + 20002
bfErrInvalidFileParam = vbObjectError + 20003
End Enum
Public Enum bfLockConstants
lockNone ' 0
lockShared ' 1
lockReadWrite ' 2
lockRead ' 3
lockWrite ' 4
End Enum
Public Enum bfVarTypeConstants
vtInteger = vbInteger ' 2
vtLong = vbLong ' 3
vtSingle = vbSingle ' 4
vtDouble = vbDouble ' 5
vtCurrency = vbCurrency ' 6
vtDate = vbDate ' 7
vtString = vbString ' 8
vtBoolean = vbBoolean ' 11
vtVariant = vbVariant ' 12
vtByte = vbByte ' 17
End Enum
Private mFNr As Long
Private mFSO As New FileSystemObject
Private pFile As File
Private pLock As bfLockConstants
Public Property Get File() As File
Set File = pFile
End Property
Public Property Get LockMode() As bfLockConstants
LockMode = pLock
End Property
Public Property Get Path() As String
If Not (pFile Is Nothing) Then
Path = pFile.Path
End If
End Property
Public Sub OpenFile(File As Variant, _
Optional ByVal LockMode As bfLockConstants, _
Optional ByVal ForceCreate As Boolean, _
Optional ByVal OverWrite As Boolean)
If mFNr Then
Err.Raise bfErrFileAlreadyOpen, "BinaryFile.OpenFile"
End If
If IsObject(File) Then
If TypeOf File Is File Then
Set pFile = File
Else
Err.Raise bfErrInvalidObject, "BinaryFile.OpenFile"
End If
ElseIf VarType(File) = vbString Then
If mFSO.FileExists(File) Then
Set pFile = mFSO.GetFile(File)
Else
If ForceCreate Then
On Error Resume Next
Set pFile = mFSO.CreateTextFile(File, OverWrite)
If Err.Number Then
Err.Raise Err.Number, "BinaryFile.OpenFile", _
Err.Description
End If
Else
Err.Raise bfErrFileNotFound, "BinaryFile.OpenFile", File
End If
End If
Else
Err.Raise bfErrInvalidFileParam, "BinaryFile.OpenFile"
End If
pLock = LockMode
On Error GoTo OpenFile_Error
mFNr = FreeFile
Select Case pLock
Case lockNone
Open pFile.Path For Binary As #mFNr
Case lockShared
Open pFile.Path For Binary Shared As #mFNr
Case lockReadWrite
Open pFile.Path For Binary Lock Read Write As #mFNr
Case lockRead
Open pFile.Path For Binary Lock Read As #mFNr
Case lockWrite
Open pFile.Path For Binary Lock Write As #mFNr
End Select
Exit Sub
OpenFile_Error:
Err.Raise Err.Number, "BinaryFile.OpenFile", Err.Description
End Sub
Public Function GetData(Optional ByVal Position As Long = -1, _
Optional ByVal VType As bfVarTypeConstants = vtVariant, _
Optional ByVal Length As Long) As Variant
Dim nInteger As Integer
Dim nLong As Long
Dim nSingle As Single
Dim nDouble As Double
Dim nCurrency As Currency
Dim nDate As Date
Dim nString As String
Dim nBoolean As Boolean
Dim nVariant As Variant
Dim nByte As Byte
On Error GoTo GetData_Error
If Position >= 0 Then
Select Case VType
Case vtInteger
Get #mFNr, Position, nInteger
GetData = nInteger
Case vtLong
Get #mFNr, Position, nLong
GetData = nLong
Case vtSingle
Get #mFNr, Position, nSingle
GetData = nSingle
Case vtDouble
Get #mFNr, Position, nDouble
GetData = nDouble
Case vtCurrency
Get #mFNr, Position, nCurrency
GetData = nCurrency
Case vtDate
Get #mFNr, Position, nDate
GetData = nDate
Case vtString
If Length > 0 Then
nString = Space$(Length)
Else
nString = Space$(LOF(mFNr))
End If
Get #mFNr, Position, nString
GetData = nString
Case vtBoolean
Get #mFNr, Position, nBoolean
GetData = nBoolean
Case vtVariant
Get #mFNr, Position, nVariant
GetData = nVariant
Case vtByte
Get #mFNr, Position, nByte
GetData = nByte
End Select
Else
Select Case VType
Case vtInteger
Get #mFNr, , nInteger
GetData = nInteger
Case vtLong
Get #mFNr, , nLong
GetData = nLong
Case vtSingle
Get #mFNr, , nSingle
GetData = nSingle
Case vtDouble
Get #mFNr, , nDouble
GetData = nDouble
Case vtCurrency
Get #mFNr, , nCurrency
GetData = nCurrency
Case vtDate
Get #mFNr, , nDate
GetData = nDate
Case vtString
If Length > 0 Then
nString = Space$(Length)
Else
nString = Space$(LOF(mFNr))
End If
Get #mFNr, , nString
GetData = nString
Case vtBoolean
Get #mFNr, , nBoolean
GetData = nBoolean
Case vtVariant
Get #mFNr, , nVariant
GetData = nVariant
Case vtByte
Get #mFNr, , nByte
GetData = nByte
End Select
End If
Exit Function
GetData_Error:
Err.Raise Err.Number, "BinaryFile.GetData", Err.Description
End Function
Public Sub PutData(Value As Variant, _
Optional ByVal Position As Long = -1, _
Optional ByVal VType As bfVarTypeConstants = vtVariant)
Dim nInteger As Integer
Dim nLong As Long
Dim nSingle As Single
Dim nDouble As Double
Dim nCurrency As Currency
Dim nDate As Date
Dim nString As String
Dim nBoolean As Boolean
Dim nVariant As Variant
Dim nByte As Byte
On Error GoTo PutData_Error
If Position >= 0 Then
If IsArray(Value) Then
Put #mFNr, Position, Value
Else
Select Case VType
Case vtInteger
nInteger = CInt(Value)
Put #mFNr, Position, nInteger
Case vtLong
nLong = CLng(Value)
Put #mFNr, Position, nLong
Case vtSingle
nSingle = CSng(Value)
Put #mFNr, Position, nSingle
Case vtDouble
nDouble = CDbl(Value)
Put #mFNr, Position, nDouble
Case vtCurrency
nCurrency = CCur(Value)
Put #mFNr, Position, nCurrency
Case vtDate
nDate = CDate(Value)
Put #mFNr, Position, nDate
Case vtString
nString = CStr(Value)
Put #mFNr, Position, nString
Case vtBoolean
nBoolean = CBool(Value)
Put #mFNr, Position, nBoolean
Case vtVariant
Put #mFNr, Position, Value
Case vtByte
nByte = CByte(Value)
Put #mFNr, Position, nByte
End Select
End If
Else
If IsArray(Value) Then
Put #mFNr, , Value
Else
Select Case VType
Case vtInteger
nInteger = CInt(Value)
Put #mFNr, , nInteger
Case vtLong
nLong = CLng(Value)
Put #mFNr, , nLong
Case vtSingle
nSingle = CSng(Value)
Put #mFNr, , nSingle
Case vtDouble
nDouble = CDbl(Value)
Put #mFNr, , nDouble
Case vtCurrency
nCurrency = CCur(Value)
Put #mFNr, , nCurrency
Case vtDate
nDate = CDate(Value)
Put #mFNr, , nDate
Case vtString
nString = CStr(Value)
Put #mFNr, , nString
Case vtBoolean
nBoolean = CBool(Value)
Put #mFNr, , nBoolean
Case vtVariant
Put #mFNr, , Value
Case vtByte
nByte = CByte(Value)
Put #mFNr, , nByte
End Select
End If
End If
Exit Sub
PutData_Error:
Err.Raise Err.Number, "BinaryFile.PutData", Err.Description
End Sub
Public Sub SeekPos(ByVal Position As Long)
On Error Resume Next
Seek #mFNr, Position
If Err.Number Then
Err.Raise Err.Number, "BinarayFile.SeekPos", Err.Description
End If
End Sub
Public Sub CloseFile()
On Error Resume Next
Close #mFNr
End Sub
Private Sub Class_Terminate()
CloseFile
End Sub
|
|
|