Советчик
Профиль
Группа: Модератор
Сообщений: 20581
Регистрация: 8.4.2004
Где: Зеленоград
Репутация: 34
Всего: 454
|
| Цитата | | Класс, позволяющий работать с базами данных в формате DBF. Можно создавать базы, добавлять и удалять записи. Инструкции внутри архива в файле Readme.txt |
| Код | ' (c) BASIC Production 2005
' URL: http://basicproduction.nm.ru
' E-Mail: [email protected]
Private Declare Function OemToChar Lib "user32.dll" Alias "OemToCharA" ( _
lpszSrc As Any, _
lpszDst As Any) As Long
Private Declare Function CharToOem Lib "user32.dll" Alias "CharToOemA" ( _
lpszSrc As Any, _
lpszDst As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Const FILE_BEGIN = 0
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32.dll" ( _
ByVal hFile As Long) As Long
Private Type FieldDescriptor
FieldName(10) As Byte
FieldType As Byte
FieldAddr As Long
FieldLen As Byte
DecimalLen As Byte
Reserved1 As Integer
WorkID As Byte
Reserved2 As Integer
SET_FIELDS As Byte
Reserved4(6) As Byte
Dbase4MDX As Byte
End Type
Private Type DBFHDR
Flag As Byte '1
YearMonthDay(2) As Byte '4
RowsCount As Long '8
HeaderSize As Integer '10
RowSize As Integer '12
Reserved(16) As Byte
Unknown65 As Byte
Reserved1(1) As Byte
End Type
Public Enum ColumnType
C_String = 67 'Asc("C") '(Символы) Все символы кодовой страницы OEM
D_Data_YYYYMMDD = 68 'Asc("D") '(Дата) Числа и символ-разделитель для месяца, дня и года (внутренний формат записи - 8 цифр в формате YYYYMMDD)
F_BinFPU = 70
L_Logical = 76 'Asc("L") '(Логический) ? Y y N n T t F f (? - не инициализировано)
M_Memo = 77 'Asc("M") '(Мемо) Все символы кодовой страницы OEM (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока)
N_Decimal = 78 'Asc("N") '(Числовой) - . 0 1 2 3 4 5 6 7 8 9
End Enum
Private HeaderColumns(255) As FieldDescriptor, HeaderColumnsIDx As Byte
Private DbfInfo As DBFHDR, hFileDBF As Long
Private IsOpen As Boolean
Private FileDBF As String
Public Function AddEmptyRows(ByVal Count As Long) As Boolean
If Count = 0 Then Exit Function
Dim RowArray() As Byte, RowStr As String
RowStr = Space$(DbfInfo.RowSize * Count)
RowArray = StrConv(RowStr, vbFromUnicode)
If (DbfInfo.HeaderSize + (DbfInfo.RowsCount * DbfInfo.RowSize) + 1) > LOF(hFileDBF) Then Exit Function
Seek #hFileDBF, DbfInfo.HeaderSize + (DbfInfo.RowsCount * (DbfInfo.RowSize)) + 1
Put #hFileDBF, , CByte(32)
Put #hFileDBF, , RowArray
Put #hFileDBF, , CByte(&H1A)
DbfInfo.RowsCount = DbfInfo.RowsCount + Count
Put #hFileDBF, 1, DbfInfo
End Function
Public Function AddRow(RowCols As String, Optional ByVal UseOEM As Boolean = True) As Boolean
If Len(RowCols) < (DbfInfo.RowSize - 1) Then
RowCols = RowCols & Space$((DbfInfo.RowSize - 1) - Len(RowCols))
ElseIf Len(RowCols) > (DbfInfo.RowSize - 1) Then
RowCols = Left$(RowCols, DbfInfo.RowSize - 1)
End If
Dim RowArray() As Byte, TestByte As Byte
RowArray = StrConv(RowCols, vbFromUnicode)
If UseOEM Then
ReDim Preserve RowArray(UBound(RowArray) + 1)
RowArray(UBound(ByteArr)) = 0
CharToOem RowArray(0), RowArray(0)
ReDim Preserve RowArray(UBound(RowArray) - 1)
End If
If (DbfInfo.HeaderSize + (DbfInfo.RowsCount * DbfInfo.RowSize) + 1) > LOF(hFileDBF) Then Exit Function
Seek #hFileDBF, DbfInfo.HeaderSize + (DbfInfo.RowsCount * (DbfInfo.RowSize)) + 1
Put #hFileDBF, , CByte(32)
Put #hFileDBF, , RowArray
Put #hFileDBF, , CByte(&H1A)
DbfInfo.RowsCount = DbfInfo.RowsCount + 1
Put #hFileDBF, 1, DbfInfo
End Function
Public Function AddColumn(Caption As String, ByVal ColType As ColumnType, ByVal Length As Integer, Optional ByVal DecimalCount As Byte) As Boolean
If IsDbfOpen Then Exit Function
If HeaderColumnsIDx = 255 Then Exit Function
If Len(Caption) > 11 Then
Exit Function
ElseIf Len(Caption) < 11 Then
Caption = Caption & Space$(11 - Len(Caption))
End If
For MkName = 0 To 10
HeaderColumns(HeaderColumnsIDx).FieldName(MkName) = Asc(Mid$(Caption, MkName + 1, 1))
Next MkName
HeaderColumns(HeaderColumnsIDx).FieldType = ColType
HeaderColumns(HeaderColumnsIDx).FieldLen = Length
HeaderColumns(HeaderColumnsIDx).DecimalLen = DecimalCount
HeaderColumnsIDx = HeaderColumnsIDx + 1
AddColumn = True
End Function
Public Sub RemoveColumn()
If IsDbfOpen Then Exit Sub
If HeaderColumnsIDx = 0 Then Exit Sub
HeaderColumnsIDx = HeaderColumnsIDx - 1
End Sub
Public Sub ResetColumns()
If IsDbfOpen Then Exit Sub
HeaderColumnsIDx = 0
End Sub
Public Sub EraseColumns()
If HeaderColumnsIDx < 1 Then Exit Sub
Dim tmpColumn As FieldDescriptor, EnumCols As Byte
For EnumCols = 0 To HeaderColumnsIDx - 1
HeaderColumns(EnumCols) = tmpColumn
Next EnumCols
HeaderColumnsIDx = 0
End Sub
Public Function CreateDBF(FileName As String) As Boolean
On Error GoTo CantCreate
If HeaderColumnsIDx < 1 Then Exit Function
If IsOpen Then Exit Function
Dim DbfInfo2 As DBFHDR
DbfInfo = DbfInfo2
DbfInfo.Flag = 3
DbfInfo.HeaderSize = Len(DbfInfo) + 1 + (Len(HeaderColumns(0)) * (HeaderColumnsIDx))
DbfInfo.RowsCount = 0
For CalcRowSize = 0 To HeaderColumnsIDx - 1
DbfInfo.RowSize = DbfInfo.RowSize + HeaderColumns(CalcRowSize).FieldLen
Next CalcRowSize
DbfInfo.RowSize = DbfInfo.RowSize + 1
DbfInfo.YearMonthDay(0) = 100 + Val(Format$(Date$, "yy"))
DbfInfo.YearMonthDay(1) = Val(Format$(Date$, "mm"))
DbfInfo.YearMonthDay(2) = Val(Format$(Date$, "dd"))
DbfInfo.Unknown65 = &H65
hFileDBF = FreeFile
Open FileName For Binary As hFileDBF
Put #hFileDBF, , DbfInfo
For CalcRowSize = 0 To HeaderColumnsIDx - 1
Put #hFileDBF, , HeaderColumns(CalcRowSize)
Next CalcRowSize
Put #hFileDBF, , CByte(13)
Put #hFileDBF, , CByte(&H1A)
IsOpen = True
FileDBF = FileName
CreateDBF = True
Exit Function
CantCreate:
Exit Function
End Function
Public Function OpenDBF(FileName As String) As Boolean
If Len(Dir$(FileName)) = 0 Then Exit Function
Dim GetDescriptors As Boolean
hFileDBF = FreeFile
Open FileName For Binary As hFileDBF
If LOF(hFileDBF) < Len(DbfInfo) Then Exit Function
Get #hFileDBF, , DbfInfo
GetDescriptors = True
While GetDescriptors
Get #hFileDBF, , HeaderColumns(HeaderColumnsIDx)
If HeaderColumns(HeaderColumnsIDx).FieldName(0) = 13 Then
GetDescriptors = False
Else
HeaderColumnsIDx = HeaderColumnsIDx + 1
End If
If (Seek(hFileDBF) + Len(HeaderColumns(0))) > LOF(hFileDBF) Then GetDescriptors = False
Wend
IsOpen = True
FileDBF = FileName
OpenDBF = True
End Function
Public Sub CloseDBF()
DbfInfo.YearMonthDay(0) = 100 + Val(Format$(Date$, "yy"))
DbfInfo.YearMonthDay(1) = Val(Format$(Date$, "mm"))
DbfInfo.YearMonthDay(2) = Val(Format$(Date$, "dd"))
Put #hFileDBF, 1, DbfInfo
Close hFileDBF
FileDBF = ""
hFileDBF = 0
IsOpen = False
End Sub
Public Function ColumnsCount() As Byte
ColumnsCount = HeaderColumnsIDx
End Function
Public Function RowsCount() As Long
RowsCount = DbfInfo.RowsCount
End Function
Public Function GetRow(ByVal RowNumber As Long, Optional ByVal UseOEM As Boolean = True) As String
If HeaderColumnsIDx < 1 Then Exit Function
If RowNumber = 0 Or RowNumber > DbfInfo.RowsCount Then
Exit Function
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte, ByteArr() As Byte
ReDim ByteArr(DbfInfo.RowSize - 2)
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + (DbfInfo.RowSize * RowNumber)
Get #hFileDBF, , DelFlag
Get #hFileDBF, , ByteArr()
If UseOEM Then
'Dim DstByteArr() As Byte
ReDim Preserve ByteArr(UBound(ByteArr) + 1)
ByteArr(UBound(ByteArr)) = 0
'ReDim DstByteArr(UBound(ByteArr))
OemToChar ByteArr(0), ByteArr(0)
GetRow = StrConv(ByteArr, vbUnicode)
Exit Function
End If
GetRow = StrConv(ByteArr(), vbUnicode)
End Function
Public Function GetRowCols(ColumnsArray() As String, ByVal RowNumber As Long, Optional ByVal UseOEM As Boolean = True) As Boolean
If HeaderColumnsIDx < 1 Then Exit Function
If RowNumber = 0 Then
Exit Function
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Function
Else
RowNumber = RowNumber - 1
End If
ReDim ColumnsArray(HeaderColumnsIDx - 1)
Dim DelFlag As Byte
Dim ByteArr() As Byte, ByteArr_Counter As Long
ReDim ByteArr(DbfInfo.RowSize - 2)
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + (DbfInfo.RowSize * RowNumber)
Get #hFileDBF, , DelFlag
Get #hFileDBF, , ByteArr()
If UseOEM Then
ReDim Preserve ByteArr(UBound(ByteArr) + 1)
ByteArr(UBound(ByteArr)) = 0
OemToChar ByteArr(0), ByteArr(0)
ReDim Preserve ByteArr(UBound(ByteArr) - 1)
End If
For FillCol = 0 To UBound(ColumnsArray)
ColumnsArray(FillCol) = Space$(HeaderColumns(FillCol).FieldLen)
For NextCol = 1 To HeaderColumns(FillCol).FieldLen
If ByteArr(ByteArr_Counter) = 0 Then
Else
Mid$(ColumnsArray(FillCol), NextCol, 1) = Chr$(ByteArr(ByteArr_Counter))
End If
ByteArr_Counter = ByteArr_Counter + 1
Next NextCol
Next FillCol
GetRowCols = True
End Function
Public Function GetColumn(ByVal RowNumber As Long, ByVal ColNumber As Long, Optional ByVal UseOEM As Boolean = True) As String
If HeaderColumnsIDx < 1 Then Exit Function
If ColNumber > HeaderColumnsIDx Then Exit Function
If RowNumber = 0 Then
Exit Function
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Function
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte
Dim ByteArr() As Byte, ByteArr_Counter As Long ', RowPos As Long
Dim ToSkip As Long
ColNumber = ColNumber - 1
If ColNumber = 0 Then
ToSkip = 0
Else
For SkipCols = 0 To ColNumber - 1
ToSkip = ToSkip + HeaderColumns(SkipCols).FieldLen
Next SkipCols
End If
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + (DbfInfo.RowSize * RowNumber) + ToSkip
Get #hFileDBF, , DelFlag
ReDim ByteArr(HeaderColumns(ColNumber).FieldLen - 1)
Get #hFileDBF, , ByteArr()
If UseOEM Then
ReDim Preserve ByteArr(HeaderColumns(ColNumber).FieldLen)
ByteArr(UBound(ByteArr)) = 0
OemToChar ByteArr(0), ByteArr(0)
GetColumn = StrConv(ByteArr, vbUnicode)
Exit Function
End If
GetColumn = StrConv(ByteArr, vbUnicode)
End Function
Public Sub ReplaceRow(ByVal RowNumber As Long, Value As String, Optional ByVal UseOEM As Boolean = True)
If HeaderColumnsIDx < 1 Then Exit Sub
If RowNumber = 0 Then
Exit Sub
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Sub
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte, ByteArr() As Byte
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + (DbfInfo.RowSize * RowNumber)
Get #hFileDBF, , DelFlag
If Len(Value) < DbfInfo.RowSize - 1 Then
Value = Value & Space$((DbfInfo.RowSize - 1) - Len(Value))
ElseIf Len(Value) > DbfInfo.RowSize - 1 Then
Value = Left$(Value, DbfInfo.RowSize - 1)
End If
ByteArr() = StrConv(Value, vbFromUnicode)
If UseOEM Then
ReDim Preserve ByteArr(UBound(ByteArr) + 1)
ByteArr(UBound(ByteArr)) = 0
CharToOem ByteArr(0), ByteArr(0)
ReDim Preserve ByteArr(UBound(ByteArr) - 1)
Put #hFileDBF, , ByteArr()
Exit Sub
End If
Put #hFileDBF, , ByteArr()
End Sub
Public Sub ReplaceRowCols(ColumnsArray() As String, ByVal RowNumber As Long, Optional ByVal UseOEM As Boolean = True)
If HeaderColumnsIDx < 1 Then Exit Sub
If RowNumber = 0 Then
Exit Sub
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Sub
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte
Dim ByteArr() As Byte, ByteArr_Counter As Long
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + (DbfInfo.RowSize * RowNumber)
Get #hFileDBF, , DelFlag
For SaveCols = 0 To HeaderColumnsIDx - 1
If SaveCols > UBound(ColumnsArray()) Then Exit For
ByteArr() = StrConv(ColumnsArray(SaveCols), vbFromUnicode)
If UseOEM Then
ReDim Preserve ByteArr(HeaderColumns(SaveCols).FieldLen)
ByteArr(UBound(ByteArr)) = 0
CharToOem ByteArr(0), ByteArr(0)
End If
ReDim Preserve ByteArr(HeaderColumns(SaveCols).FieldLen - 1)
Put #hFileDBF, , ByteArr()
Next SaveCols
End Sub
Public Sub ReplaceColumn(ByVal RowNumber As Long, ByVal ColNumber As Long, Value As String, Optional ByVal UseOEM As Boolean = True)
If HeaderColumnsIDx < 1 Then Exit Sub
If ColNumber > HeaderColumnsIDx Then Exit Sub
If ColNumber < 1 Then Exit Sub
If RowNumber = 0 Then
Exit Sub
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Sub
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte
Dim ByteArr() As Byte, ByteArr_Counter As Long
Dim ToSkip As Long
ColNumber = ColNumber - 1
If ColNumber = 0 Then
ToSkip = 0
Else
For SkipCols = 0 To ColNumber - 1
ToSkip = ToSkip + HeaderColumns(SkipCols).FieldLen
Next SkipCols
End If
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + ((DbfInfo.RowSize) * RowNumber) + ToSkip
Get #hFileDBF, , DelFlag
'HeaderColumns(SaveCols)
If Len(Value) < HeaderColumns(ColNumber).FieldLen Then
Select Case HeaderColumns(ColNumber).FieldType
Case Asc("C")
Value = Value & Space$(HeaderColumns(ColNumber).FieldLen - Len(Value))
Case Else
Value = Space$(HeaderColumns(ColNumber).FieldLen - Len(Value)) & Value
End Select
End If
ByteArr = StrConv(Value, vbFromUnicode)
If UseOEM Then
ReDim Preserve ByteArr(UBound(ByteArr) + 1)
ByteArr(UBound(ByteArr)) = 0
CharToOem ByteArr(0), ByteArr(0)
End If
ReDim Preserve ByteArr(HeaderColumns(ColNumber).FieldLen - 1)
Put #hFileDBF, , ByteArr()
End Sub
Function IsRowDeleted(ByVal RowNumber As Long) As Boolean
If RowNumber = 0 Then
Exit Function
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Function
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte
Seek #hFileDBF, DbfInfo.HeaderSize + ((DbfInfo.RowSize) * RowNumber)
Get #hFileDBF, , DelFlag
If DelFlag = Asc("*") Then IsRowDeleted = True
End Function
Sub DeleteRow(ByVal RowNumber As Long, Optional ByVal DeleteFlag As Boolean = True)
If RowNumber = 0 Then
Exit Sub
ElseIf RowNumber > DbfInfo.RowsCount Then
Exit Sub
Else
RowNumber = RowNumber - 1
End If
Dim DelFlag As Byte
If DeleteFlag Then DelFlag = Asc("*") Else DelFlag = 32
Seek #hFileDBF, DbfInfo.HeaderSize + 1 + ((DbfInfo.RowSize) * RowNumber)
Put #hFileDBF, , DelFlag
End Sub
Function GetColType(ByVal ColNumber As Byte) As Byte
If ColNumber > HeaderColumnsIDx Or ColNumber < 1 Then Exit Function
ColNumber = ColNumber - 1
GetColType = HeaderColumns(ColNumber).FieldType
End Function
Function GetColSize(ByVal ColNumber As Byte) As Byte
If ColNumber > HeaderColumnsIDx Or ColNumber < 1 Then Exit Function
ColNumber = ColNumber - 1
GetColSize = HeaderColumns(ColNumber).FieldLen - 1
End Function
Function GetColName(ByVal ColNumber As Byte) As String
If ColNumber > HeaderColumnsIDx Or ColNumber < 1 Then Exit Function
ColNumber = ColNumber - 1
GetColName = StrConv(HeaderColumns(ColNumber).FieldName, vbUnicode)
End Function
Public Function IsDbfOpen() As Boolean
IsDbfOpen = IsOpen
End Function
Public Sub Defrag()
Seek #hFileDBF, DbfInfo.HeaderSize + 1
Dim ByteArr() As Byte, DstByteArr() As Byte, DelFlag As Byte
ReDim ByteArr(DbfInfo.RowSize * DbfInfo.RowsCount)
ReDim DstByteArr(DbfInfo.RowSize * DbfInfo.RowsCount)
Get #hFileDBF, , ByteArr()
Dim DelRecords As Long, RecPos As Long, RecID As Long, RecsCount As Long
For DelRecords = 0 To UBound(ByteArr) Step (DbfInfo.RowSize)
If ByteArr(DelRecords) = 32 Then
DstByteArr(RecPos) = 32
CopyMemory DstByteArr(RecPos + 1), ByteArr(DelRecords + 1), DbfInfo.RowSize - 1
RecPos = RecPos + DbfInfo.RowSize
RecID = RecID + 1
End If
Next DelRecords
Put #hFileDBF, 5, RecID
DbfInfo.RowsCount = RecID
Seek #hFileDBF, DbfInfo.HeaderSize + 1
If RecPos = 0 Then
Else
RecPos = RecPos - 1
ReDim Preserve DstByteArr(RecPos)
Put #hFileDBF, , DstByteArr
End If
Put #hFileDBF, , CByte(&H1A)
Dim lngHandle As Long
lngHandle = CreateFile(DatabaseName, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If lngHandle <> 0 Then
SetFilePointer lngHandle, Seek(hFileDBF) - 1, 0, FILE_BEGIN
SetEndOfFile lngHandle
CloseHandle lngHandle
Else
MsgBox "Cannot set EOF" & vbCr & "CreateFile failed!", 16, "BPDBF"
End If
End Sub
Function DatabaseName() As String
DatabaseName = FileDBF
End Function |
Код формы: | Код | Private MyDBF As BPDBF
Private Sub Form_Load()
Set MyDBF = New BPDBF
End Sub |
Ссылки на первоисточник: Страница загрузкиПрямая ссылка на файлПервоисточник найден by Voldemar2004 --------------------
О(б)суждение моих действий - в соответствующей теме, пожалуйста. Или в РМ. И высшая инстанция - Администрация форума. |
Класс для работы с DBF 
Загрузка ...
