If j + r + m <= n Then Call Sli(A(), j + m, r, m, n) 'Слияние "концов"

Call Sli(A(), j + m, r - m, m, n)

End If

End If

End Sub

Public Sub Bose(A() As Datap, n As Integer)

'сортировка слиянием

Dim m As Integer, j As Integer

m = 1

Do

j = 1 'Цикл слияния списков равного размера:

While j + m <= n

Call Sli(A(), j, m, m, n)

j = j + m + m

Wend

m = m + m 'Удвоение размера списка перед началом нового прохода

Loop Until m >= n 'Конец цикла, реализующего все дерево слияний

End Sub

Главная программа

Option Explicit

Dim BeginStroka As Long 'номер первой строки области вывода

Dim LastStroka As Long 'номер последней строки области вывода

Dim OldIndex As Integer 'номер предыдущей активной записи

Dim IndexForSub As Integer 'номер записи для использования в подпрограммах

Private Sub ReRead()

'обновление сведений о файле данных

Seek #1, 1

Do While Not EOF(1) ' Cчитываем весь файл до конца.

Get #1,, Stroka ' Читаем в цикле каждую запись.

Loop

LastStroka = Seek(1) - 1

Label5.Caption = "Всего записей: " + Str(LastStroka - 1)

ShowRecords

End Sub

Private Sub cmdHelp_Click()

'вывод справки о программе

frmHelp.Show vbModal

End Sub

Private Sub cmdPrintAll_Click()

'вывод таблицы с базой данных

Dim x As Long 'счетчик цикла

frmOut.List1.Clear

frmOut.List1.AddItem ("------------------------------------------------------------")

frmOut.List1.AddItem ("|Код |Название |Количество|Страна |Дата|Срок|")

frmOut.List1.AddItem ("|товара| |на складе |производитель |выработки |годности|")

frmOut.List1.AddItem ("|-----|------------------|-------|-----------|-------|--------|")

For x = 1 To LastStroka - 1

Get #1, x, Stroka

frmOut.List1.AddItem ("|" & Format(Format(Stroka.ID), "@@@@@@") & "|" & _

Format(Stroka.Name, "@@@@@@@@@@@@@@@@@@@@@@@ @@") & "|" & _

Format(Format(Stroka.Kol), "@@@@@@@@@@") & "|" & _

Format(Stroka.Strana, "@@@@@@@@@@@@@@@") & "|" & _

Format(Stroka.DataV, "@@@@@@@@@@") & "|" & _

Format(Format(Stroka.SrokG), "@@@@@@@@") & "|")

Next x

frmOut.Caption = "База данных по товарам (полная)"

frmOut.List1.AddItem ("------------------------------------------------------------")

frmOut.Show vbModal

End Sub

Private Sub cmdQuit_Click()

'выход из программы

Unload Me

End

End Sub

Private Sub cmdSort_Click()

'сортировка по количеству и вывод базы данных

Dim A() As Datap 'массив записей

Dim x As Long 'счетчик цикла

ReDim A(LastStroka)

For x = 1 To LastStroka - 1

Get #1, x, Stroka

A(x) = Stroka

Next x

Call Bose(A(), LastStroka - 1)

frmOut.List1.Clear

frmOut.List1.AddItem ("---------------------------------------------")

frmOut.List1.AddItem ("|Код |Название |Количество|")

frmOut.List1.AddItem ("|товара| |на складе |")

frmOut.List1.AddItem ("|------|-------------------------|----------|")

For x = 1 To LastStroka - 1

frmOut.List1.AddItem ("|" & Format(Format(A(x).ID), "@@@@@@") & "|" & _

Format(A(x).Name, "@@@@@@@@@@@@@@@@@@@@@@@ @@") & "|" & _

Format(Format(A(x).Kol), "@@@@@@@@@@") & "|")

Next x

frmOut.Caption = "База данных по товарам (сортировка по количеству)"

frmOut.List1.AddItem ("---------------------------------------------")

frmOut.Show vbModal

End Sub

Private Sub Form_Load()

'инициализация программы

OldIndex = 0

Open App.Path & "\" & BDFile For Random As #1 Len = Len(Stroka)

Do While Not EOF(1) ' Цикл до конца файла

Get #1,, Stroka ' Читает следующую запись

Loop

LastStroka = Seek(1) - 1

VScroll1.Min = 1

If LastStroka > 10 Then

VScroll1.Max = LastStroka

VScroll1.LargeChange = 10

Else

VScroll1.Max = LastStroka

VScroll1.LargeChange = 1

End If

VScroll1.SmallChange = 1

VScroll1.Value = 1

BeginStroka = VScroll1.Value

ReRead

End Sub

Private Sub ShowRecords()

'показать 10 записей

Dim x As Long 'счетчик цикла

On Error Resume Next

For x = 0 To 9

Get #1, x + BeginStroka, Stroka

Text1(x) = RTrim(Stroka.Name)

Text2(x) = Stroka.Kol

Text3(x) = RTrim(Stroka.Strana)

Text5(x) = Stroka.ID

Text6(x) = RTrim(Stroka.DataV)

Text7(x) = Stroka.SrokG

Command1(x).Caption = "Х"

If Text5(x).Text = 0 Then

Command1(x).Caption = "->"

End If

If LastStroka - BeginStroka < 10 And x + BeginStroka > LastStroka Then

Text1(x).Visible = False

Text2(x).Visible = False

Text3(x).Visible = False

Text5(x).Visible = False

Text6(x).Visible = False

Text7(x).Visible = False

Command1(x).Visible = False

Else

Text1(x).Visible = True

Text2(x).Visible = True

Text3(x).Visible = True

Text5(x).Visible = True

Text6(x).Visible = True

Text7(x).Visible = True

Command1(x).Visible = True

End If

Next x

On Error GoTo 0

End Sub

Private Sub VScroll1_Change()

'изменение линейки прокртки

BeginStroka = VScroll1.Value

ShowRecords

End Sub

Private Sub Text1_GotFocus(Index As Integer)

'приобретение фокуса элементом Text1

IndexForSub = Index

MakeRecord

End Sub

Private Sub Text2_GotFocus(Index As Integer)

'приобретение фокуса элементом Text2

IndexForSub = Index

MakeRecord

End Sub

Private Sub Text3_GotFocus(Index As Integer)

'приобретение фокуса элементом Text3

IndexForSub = Index

MakeRecord

End Sub

Private Sub Text5_GotFocus(Index As Integer)

'приобретение фокуса элементом Text5

IndexForSub = Index

MakeRecord

End Sub

Private Sub Text6_GotFocus(Index As Integer)

'приобретение фокуса элементом Text6

IndexForSub = Index

MakeRecord

End Sub

Private Sub Text7_GotFocus(Index As Integer)

'приобретение фокуса элементом Text7

IndexForSub = Index

MakeRecord

End Sub

Private Sub MakeRecord()

'сохранение записи в файле

Stroka.Name = Text1(OldIndex)

Stroka.Kol = Val(Text2(OldIndex))

Stroka.Strana = Text3(OldIndex)

Stroka.ID = Val(Text5(OldIndex))

Stroka.DataV = Text6(OldIndex)

Stroka.SrokG = Val(Text7(OldIndex))

Command1(OldIndex).Caption = ""

Put #1, OldIndex + BeginStroka, Stroka

OldIndex = IndexForSub

ReRead

End Sub

Private Sub Command1_Click(Index As Integer)

'удаление текущей записи

Dim x As Integer 'счетчик цикла

Dim Z As Integer 'счетчик записей

Open App.Path & "\Copybd.bzd" For Random As #2 Len = Len(Stroka)

For x = 1 To LastStroka - 1

Get #1, x, Stroka

If Index + BeginStroka <> x Then

Z = Z + 1

Put #2, Z, Stroka

End If

Next x

Close

Kill App.Path & "\" & BDFile

Name App.Path & "\Copybd.bzd" As App.Path & "\" & BDFile

Open App.Path & "\" & BDFile For Random As #1 Len = Len(Stroka)

ReRead

End Sub

Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

'обработка нажатия клавиш на элементе Text1

If KeyCode = 13 Then

IndexForSub = Index

Text2(Index).SetFocus

MakeRecord

End If

End Sub

Private Sub Text2_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

'обработка нажатия клавиш на элементе Text2

If KeyCode = 13 Then

IndexForSub = Index

Text3(Index).SetFocus

MakeRecord

End If

End Sub

Private Sub Text3_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

'обработка нажатия клавиш на элементе Text3

If KeyCode = 13 Then

Text6(Index).SetFocus

IndexForSub = Index

MakeRecord

End If

End Sub

Private Sub Text5_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

'обработка нажатия клавиш на элементе Text5

If KeyCode = 13 Then

Text1(Index).SetFocus

IndexForSub = Index

MakeRecord

End If

End Sub

Private Sub Text6_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

'обработка нажатия клавиш на элементе Text6

If KeyCode = 13 Then

Text7(Index).SetFocus

IndexForSub = Index

MakeRecord

End If

End Sub

Private Sub Text7_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

'обработка нажатия клавиш на элементе Text7

If KeyCode = 13 Then

Text5(Index).SetFocus

IndexForSub = Index

MakeRecord

End If

End Sub

Размещено на Allbest.ru