Option Explicit
'****************************************************
'Internal variables
'****************************************************
'Объявление класса для работы с диалоговыми окнами
Private dlgDb As New clsCommonDialog
Private fso As New FileSystemObject ' "верхний" объект библиотеки FSO
Private tsOpen As TextStream '|
Private tsSave As TextStream '|текстовые потоки библиотеки FSO
Private tsNew As TextStream '|
Private CountEntries As Integer 'количество записей
Private CurrentEntries As Integer 'номер текущей записи
Private flagChange As Boolean 'флаг для отслеживания изменений в БД
Private colTxtDB As colDB 'объектная модель БД
'****************************************************
'****************************************************
Private Sub cmdDB_Click(Index As Integer)
Select Case Index
Case 0 'Создание нового файла
On Error GoTo LocalErr
'если файл уже открыт
If Len(Caption) > 14 Then 'надпись длиннее чем "Demo FSO as DB"
CloseFile
Set colTxtDB = Nothing
End If
With dlgDb
.DialogTitle = "Создать текстовую БД"
.Filter = "Текстовые БД (*.tdb)|*.tdb"
.FilterIndex = 1
.ShowOpen
Set tsNew = fso.CreateTextFile(.FileName, True)
tsNew.Close
Set colTxtDB = New colDB
Caption = "Demo FSO as DB (" & .FileTitle & ")"
End With
CountEntries = 0
CurrentEntries = 0
Case 1 'Открытие существующего файла
Dim strLastname As String, strFirstName As String
Dim strNumber As String, intID As Integer, i As Integer
On Error GoTo LocalErr
'если файл уже открыт
If Len(Caption) > 14 Then 'надпись длиннее чем "Demo FSO as DB"
CloseFile
Set colTxtDB = Nothing
End If
With dlgDb
.DialogTitle = "Открыть текстовую БД"
.Filter = "Текстовые БД (*.tdb)|*.tdb"
.FilterIndex = 1
.ShowOpen
Set colTxtDB = New colDB
Caption = "Demo FSO as DB (" & .FileTitle & ")"
'открываем выбранный файл для считывания информации
Set tsOpen = fso.OpenTextFile(.FileName, ForReading)
'считываем количество записей
CountEntries = tsOpen.ReadLine
'считываем записи
For i = 1 To CountEntries
strLastname = tsOpen.ReadLine
strFirstName = tsOpen.ReadLine
strNumber = tsOpen.ReadLine
intID = tsOpen.ReadLine
'и добавляем их в объект
colTxtDB.Add strLastname, strFirstName, strNumber, intID
Next
tsOpen.Close 'закрываем файл
End With
CurrentEntries = 1
DBInForm CurrentEntries
Case 2 'выход
Unload Me
End Select
Exit Sub
'обработка ошибок
LocalErr:
Select Case Err.Number
Case 5 'пользователь нажал Cancel
Case 32755
Case 62 'попытка считывания из пустого файла
CountEntries = 0
CurrentEntries = 0
Case Else
MsgBox "<" & Err.Number & "> - " & Err.Description
End Select
End Sub
'Пересылка данных в текстовые поля
Private Sub DBInForm(Index As Integer)
txtLastName.Text = colTxtDB(Index).LastName
txtFirstName.Text = colTxtDB(Index).FirstName
txtNumber.Text = colTxtDB(Index).Number
lblID.Caption = "Номер записи: " & colTxtDB(Index).ID
End Sub
Private Sub cmdEdit_Click(Index As Integer)
Select Case Index
Case 0 'добавить
CountEntries = CountEntries + 1
CurrentEntries = CountEntries
colTxtDB.Add txtLastName.Text, txtFirstName.Text, txtNumber.Text, CurrentEntries
DBInForm CurrentEntries
Case 1 'изменить
If CountEntries = 0 Then Exit Sub
colTxtDB(CurrentEntries).LastName = txtLastName.Text
colTxtDB(CurrentEntries).FirstName = txtFirstName.Text
colTxtDB(CurrentEntries).Number = txtNumber.Text
DBInForm CurrentEntries
Case 2 'удалить
If CountEntries = 0 Then Exit Sub
If MsgBox("Удалить
текущую
запись?", vbYesNo + vbDefaultButton2 +
vbQuestion, _
"Удаление
записи") = vbYes
Then
colTxtDB.Remove CurrentEntries
If CurrentEntries = CountEntries Then
CurrentEntries = CurrentEntries - 1
End If
CountEntries = CountEntries - 1
DBInForm CurrentEntries
End If
End Select
flagChange = True
End Sub
Private Sub cmdMove_Click(Index As Integer)
Select Case Index
Case 0 ' к первой записи
CurrentEntries = 1
Case 1 ' к предыдущей записи
CurrentEntries = CurrentEntries - 1
Case 2 'к следующей записи
CurrentEntries = CurrentEntries + 1
Case 3 ' к последней записи
CurrentEntries = CountEntries
End Select
'блокировка передвижений по записям вне диапазона
If CurrentEntries < 1 Then
CurrentEntries = 1
ElseIf CurrentEntries > CountEntries Then
CurrentEntries = CountEntries
End If
DBInForm CurrentEntries
End Sub
'запрос на сохранение БД
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseFile
'очистка памяти
Set colTxtDB = Nothing
Set tsOpen = Nothing
Set tsSave = Nothing
Set tsNew = Nothing
Set fso = Nothing
End Sub
Private Sub CloseFile()
Dim i%
If flagChange Then 'если были произведены изменения в БД
If
MsgBox("Сохранить
произведенные
изменения в
базе данных?",
_
vbYesNo
+ vbQuestion, "Закрытие
программы") = vbYes
Then
With dlgDb
.DialogTitle = "Сохранение текстовой БД"
.Filter = "Текстовые БД (*.tdb)|*.tdb"
.FilterIndex = 1
.ShowSave
Set tsSave = fso.OpenTextFile(.FileName, ForWriting)
tsSave.WriteLine CountEntries
For i = 1 To CountEntries
tsSave.WriteLine colTxtDB(i).LastName
tsSave.WriteLine colTxtDB(i).FirstName
tsSave.WriteLine colTxtDB(i).Number
tsSave.WriteLine colTxtDB(i).ID
Next
tsSave.Close
End With
End If
End If
flagChange = False
End Sub
Option Explicit
Private m_cancelled As Boolean
'****************************************************
'API function
'****************************************************
'API функция для ShowOpen method
Private
Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" _
(pOpenfilename As OpenFilename) _
As Long
'API функция для ShowSave method
Private
Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" _
(pOpenfilename As OpenFilename) _
As Long
'API функция для возвращения расширенной информации об ошибке
Private
Declare Function CommDlgExtendedError Lib "comdlg32.dll" _
() As Long
'****************************************************
'Type
'****************************************************
Private Type OpenFilename
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
iFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'****************************************************
'Internal
variables
'****************************************************
Private iAction As Integer
Private sDefaultExt As String
Private sDialogTitle As String
Private sFileName As String
Private sFileTitle As String
Private sFilter As String
Private iFilterIndex As Integer
Private lFlags As Long
Private lhdc As Long
Private sInitDir As String
Private lMaxFileSize As Long
Private lApiReturn As Long
Private lExtendedError As Long
Private bCancelError As Boolean
'****************************************************
'Properties
'****************************************************
Public Property Get Filter() As String
Filter = sFilter
End Property
Public Property Let Filter(vNewValue As String)
sFilter = vNewValue
End Property
Public Property Get FilterIndex() As Integer
FilterIndex = iFilterIndex
End Property
Public Property Let FilterIndex(vNewValue As Integer)
iFilterIndex = vNewValue
End Property
Public Property Get FileName() As String
FileName = sFileName
End Property
Public Property Let FileName(vNewValue As String)
sFileName = vNewValue
End Property
Public Property Get DialogTitle() As String
DialogTitle = sDialogTitle
End Property
Public Property Let DialogTitle(vNewValue As String)
sDialogTitle = vNewValue
End Property
Public Property Get Action() As Integer
Action = iAction
End Property
Public Property Get CancelError() As Boolean
CancelError = bCancelError
End Property
Public Property Let CancelError(vNewValue As Boolean)
bCancelError = vNewValue
End Property
Public Property Get hdc() As Long
hdc = lhdc
End Property
Public Property Let hdc(vNewValue As Long)
lhdc = vNewValue
End Property
Public Property Get FileTitle() As String
FileTitle = sFileTitle
End Property
Public Property Let FileTitle(vNewValue As String)
sFileTitle = vNewValue
End Property
Public Property Get APIReturn() As Long
APIReturn = lApiReturn
End Property
Public Property Get ExtendedError() As Long
ExtendedError = lExtendedError
End Property
Public Property Get DefaultExt() As String
DefaultExt = sDefaultExt
End Property
Public Property Let DefaultExt(vNewValue As String)
sDefaultExt = vNewValue
End Property
Public Property Get Flags() As Long
Flags = lFlags
End Property
Public Property Let Flags(vNewValue As Long)
lFlags = vNewValue
End Property
Public Property Get InitDir() As String
InitDir = sInitDir
End Property
Public Property Let InitDir(vNewValue As String)
sInitDir = vNewValue
End Property
Public Property Get MaxFileSize() As Long
MaxFileSize = lMaxFileSize
End Property
Public Property Let MaxFileSize(vNewValue As Long)
lMaxFileSize = vNewValue
End Property
'****************************************************
'Methods
'****************************************************
Public Sub ShowOpen()
ShowFileDialog (1)
End Sub
Public Sub ShowSave()
ShowFileDialog (2)
End Sub
'****************************************************
'Private
Functions
'****************************************************
Private Function sLeftOfNull(ByVal sIn As String)
Dim lNullPos As Long
sLeftOfNull = sIn
lNullPos = InStr(sIn, Chr$(0))
If lNullPos > 0 Then
sLeftOfNull = Mid$(sIn, 1, lNullPos - 1)
End If
End Function
Private Function sAPIFilter(sIn)
Dim lChrNdx As Long
Dim sOneChr As String
Dim sOutStr As String
For lChrNdx = 1 To Len(sIn)
sOneChr = Mid$(sIn, lChrNdx, 1)
If sOneChr = "|" Then
sOutStr = sOutStr & Chr$(0)
Else
sOutStr = sOutStr & sOneChr
End If
Next
sOutStr = sOutStr & Chr$(0)
sAPIFilter = sOutStr
End Function
Private Sub ShowFileDialog(ByVal iAction As Integer)
Dim tOpenFile As OpenFilename
Dim lMaxSize As Long
Dim sFileNameBuff As String
Dim sFileTitleBuff As String
On Error GoTo ShowFileDialogError
iAction = iAction
lApiReturn = 0
lExtendedError = 0
tOpenFile.lStructSize = Len(tOpenFile)
tOpenFile.hwndOwner = lhdc
tOpenFile.lpstrFilter = sAPIFilter(sFilter)
tOpenFile.iFilterIndex = iFilterIndex
If lMaxFileSize > 0 Then
lMaxSize = lMaxFileSize
Else
lMaxSize = 255
End If
sFileNameBuff = sFileName
While Len(sFileNameBuff) < lMaxSize - 1
sFileNameBuff = sFileNameBuff & " "
Wend
If lMaxFileSize = 0 Then
sFileNameBuff = Mid$(sFileNameBuff, 1, lMaxSize - 1)
Else
sFileNameBuff = Mid$(sFileNameBuff, 1, lMaxFileSize - 1)
End If
sFileNameBuff = sFileNameBuff & Chr$(0)
tOpenFile.lpstrFile = sFileNameBuff
If lMaxFileSize <> 255 Then
tOpenFile.nMaxFile = 255
End If
sFileTitleBuff = sFileTitle
While Len(sFileTitleBuff) < lMaxSize - 1
sFileTitleBuff = sFileTitleBuff & " "
Wend
If lMaxFileSize = 0 Then
sFileTitleBuff = Mid$(sFileTitleBuff, 1, lMaxSize - 1)
Else
sFileTitleBuff = Mid$(sFileTitleBuff, 1, lMaxFileSize - 1)
End If
sFileTitleBuff = sFileTitleBuff & Chr$(0)
tOpenFile.lpstrFileTitle = sFileTitleBuff
tOpenFile.lpstrInitialDir = sInitDir
tOpenFile.lpstrTitle = sDialogTitle
tOpenFile.Flags = lFlags
tOpenFile.lpstrDefExt = sDefaultExt
Select Case iAction
Case 1 'ShowOpen
lApiReturn = GetOpenFileName(tOpenFile)
Case 2 'ShowSave
lApiReturn = GetSaveFileName(tOpenFile)
Case Else 'unknown action
Exit Sub
End Select
m_cancelled = False
Select Case lApiReturn
Case 0 'user canceled
m_cancelled = True
Exit Sub
Case 1
sFileName = sLeftOfNull(tOpenFile.lpstrFile)
sFileTitle = sLeftOfNull(tOpenFile.lpstrFileTitle)
Case Else
lExtendedError = CommDlgExtendedError
End Select
Exit Sub
ShowFileDialogError:
Exit Sub
End Sub
Option Explicit
'****************************************************
'Internal
variables
'****************************************************
Private mvarLastName As String
Private mvarFirstName As String
Private mvarNumber As String
Private mvarID As Integer
'****************************************************
'Properties
'****************************************************
Public Property Let ID(ByVal vData As Integer)
mvarID = vData
End Property
Public Property Get ID() As Integer
ID = mvarID
End Property
Public Property Let Number(ByVal vData As String)
mvarNumber = vData
End Property
Public Property Get Number() As String
Number = mvarNumber
End Property
Public Property Let FirstName(ByVal vData As String)
mvarFirstName = vData
End Property
Public Property Get FirstName() As String
FirstName = mvarFirstName
End Property
Public Property Let LastName(ByVal vData As String)
mvarLastName = vData
End Property
Public Property Get LastName() As String
LastName = mvarLastName
End Property
Option Explicit
'****************************************************
'Internal
variables
'****************************************************
Private mCol As Collection
'****************************************************
'Methods
'****************************************************
Public
Function Add(LastName As String, FirstName As String, _
Number As String, ID As Integer) As clsDB
'create a new object
Dim objNewMember As clsDB
Set objNewMember = New clsDB
'set the properties passed into the method
objNewMember.LastName = LastName
objNewMember.FirstName = FirstName
objNewMember.Number = Number
objNewMember.ID = ID
mCol.Add objNewMember
'return the object created
Set Add = objNewMember
Set objNewMember = Nothing
End Function
Public Sub Remove(vntIndexKey As Variant)
mCol.Remove vntIndexKey
End Sub
'****************************************************
'Properties
'****************************************************
Public Property Get Item(vntIndexKey As Variant) As clsDB
Set Item = mCol(vntIndexKey)
End Property
Public Property Get Count() As Long
Count = mCol.Count
End Property
Public Property Get NewEnum() As IUnknown
Set NewEnum = mCol.[_NewEnum]
End Property
'****************************************************
'Class
'****************************************************
Private Sub Class_Initialize()
Set mCol = New Collection
End Sub
Private Sub Class_Terminate()
Set mCol = Nothing
End Sub