Структура заданного исходного файла и структуры данных, соответствующие данным файла
Файл – это последовательность байтов, хранящаяся в памяти.
Текстовый файл – это так же последовательность байтов, но каждый байт текстового файла можно представить кодом символа.
Заданный исходный файл – текстовый, так как в каждом байте хранится код символа.
В файле хранится текст:
Пределы воспламеняемости некоторых газов и паров в воздухе и в кислороде, % (объемы). Давление 1 бар, температура 20 °С.
Вещество Нижний предел в воздухе Верхний предел в воздухе Нижний предел в кислороде Верхний предел в кислороде
Аммиак NH3 15,0 28,0 15 79
Окись углерода СО 12,5 74 15,5 94
Водород Н2 4,0 75,6 4,0 94
Метан СН4 5,0 15,0 5 61
Метилхлорид СН3С1 7,1 18,5 8,0 66
Этан С2Н6 3,0 12,5 3,0 66
Диметилэфир С2Н6О 2,0 27,0 3,9 61
Этилен С2Н4 2,7 28,5 2,9 80
Окись этилена С2Н4О 2,6 100 — -
Ацетальдегид С2Н4О 4,0 57,0 4,0 93
Винилхлорид С2Н3С1 3,8 29,3 4,0 70
Ацетилен С2Н2 1,5 82,0 2,8 93
Трихлорэтилен С2НС13 7,9 — 10,0 65
Пропан СзН8 2,1 9,5 2,3 55
Пропилен С3Н6 2,0 11,7 2,1 53
н-Бутан C4H10 1,5 8,5 1,8 49
Диэтиловый эфир С4Н10О 1,7 36 2,0 82
1-бутилен С4Н8 1,6 10 1,8 58
2-бутилен С4Н8 1,7 9,7 1,7 55
Текст разбит на строки непечатными (управляющими) символами CR/LF.
Первая строка никак не разделена и в программе будет представлена типом String.
Вторая строка разбита на элементы непечатным (управляющим) символом горизонтальной табуляции (НТ). Для представления второй строки в программе будет использоваться строковый массив типа String.
Третья и последующие строки, так же как и вторая, разбиты на элементы символом горизонтальной табуляции (НТ), но элементы имеют разные типы (строковые и числовые), поэтому будет использоваться ЗАПИСЬ пользовательского типа “param”, состоящего из одной переменной типа String и массива типа Single — для одной строки
Type param
prop As String
vol(7) As Single
End Type
и массив ЗАПИСЕЙ – для нескольких строк.
Dim mas() As param
В тексте также вместо чисел встречается символ «дефис» («-»), что затрудняет сортировку строк, поэтому данный символ программа будет заменять на число ноль.
If smb = "-" Then
par.vol(q) = 0
Для последовательного чтения строк из файла будет использован цикл DO UNTIL, условием выхода из цикла будет являться состояние EOF (EndOfFile-конец файла). Конец файла определяется размером файла. Подпрограмма находится в отдельном модуле и вызывается главной программой.
Sub InputData(name As String, nf1 As Integer, st() As String, sk() As String, k As Integer)
k = 0
Open name For Input As nf1
Do Until EOF(nf1)
ReDim Preserve st(k)
Line Input #nf1, st(k)
ReDim Preserve sk(k)
sk(k) = st(k)
k = k + 1
Loop
Close #nf1
End Sub
Определение кодировки файла
Кодировка представляет собой таблицу символов, где каждой букве алфавита (а также цифрам и специальным знакам) присвоен свой уникальный номер — код символа.
Стандартизирована только половина таблицы, т.н. ASCII-код — первые 128 символов, которые включают в себя буквы латинского алфавита. И с ними никогда не бывает проблем. Вторая же половина таблицы (а всего в ней 256 символов — по количеству состояний, который может принять один байт) отдана под национальные символы, и в каждой стране эта часть различна. Но только в России было придумано целых 5 различных кодировок. Термин «различные» обозначает то, что одному и тому же символу соответствует разный цифровой код. Т.е. если неправильно определить кодировку текста, то пользователю предстанет абсолютно нечитаемый текст.
Использование множества кодировок в современном ПО создаёт много неудобств не только программистам, но и пользователям. Согласно рациональной точке зрения, справиться с непонятными символами можно, если программы будут автоматически распознавать кодировку входящего текста.
Для однобайтных кодировок можно учитывать тот факт, что частота использования разных букв сильно различается (например, в русском часто используется «о», но редко «ъ»). Поэтому, зная язык текста, можно легко выбрать кодировку, в которой частота байтов лучше соответствует частоте букв данного языка.
Для определения кодировки текстового файла нужно выполнить следующий план действий:
Поочередно перебирая символы из текста, определять код символа и проверять принадлежность его к каждой кодовой таблице.
Увеличивать на 1 счетчики тех кодовых таблиц, которым не противоречит код символа.
Найти максимальное значение среди счетчиков – оно укажет на наиболее вероятную кодировку.
Текст, кодированный в Unicode, выглядит иначе. Каждый символ в Unicode кодируется двумя байтами, в первом байте памяти хранится код символа Unicode, а во втором всегда 04. Поэтому чтобы определить имеет ли текст кодировку Unicode, достаточно проверить второй байт памяти, он должен хранить код 04.
Подпрограмма проверки принадлежности текста к одной из шести кодовых таблиц:
Sub FindCP(stroky() As String, msg1 As String, msg2 As String, index As Integer)
Dim s As Integer, z As Integer
Dim symb As String * 1
Dim kod As Byte
Dim scp(7) As codepage
Dim ks As String, ks1 As String
Dim ks2 As String, ne As String
ks = «Ваш текст предположительно имеет кодировку „
ne = “не „
ks1 = “Требуется „
ks2 = “Перекодировка „
For s = 0 To UBound(stroky)
For z = 1 To Len(stroky(s))
symb = Mid(stroky(s), z, 1)
kod = Asc(symb)
If cp1(kod) Then scp(0).vol = scp(0).vol + 1: scp(0).name = “КОИ-8R»
If cp2(kod) Then scp(1).vol = scp(1).vol + 1: scp(1).name = «Cp1251»--PAGE_BREAK--
If cp3(kod) Then scp(2).vol = scp(2).vol + 1: scp(2).name = «OEM»
If cp4(kod) Then scp(3).vol = scp(3).vol + 1: scp(3).name = «Cp866»
If cp5(kod) Then scp(4).vol = scp(4).vol + 1: scp(4).name = «Mac»
If cp6(kod) Then scp(5).vol = scp(5).vol + 1: scp(5).name = «ISO»
If cp71(symb) Then scp(6).vol = scp(6).vol + 1: scp(6).name = «Unicode»
Next z
Next s
z = 0
For s = 0 To 6
If scp(s).vol >= z Then
z = scp(s).vol: index = s
End If
Next s
'При совпадении счетчиков «КОИ-8R» и «cp1251» кодировка текста определяется как «cp1251»
If ((scp(0).vol = scp(1).vol) And index
If index = 1 Then
msg1 = ks & scp(index).name
msg2 = ks2 & ne & LCase(ks1)
Else:
msg1 = ks & scp(index).name
msg2 = ks1 & LCase(ks2)
End If
End Sub
Данная подпрограмма использует функции проверки принадлежности кода к заданному диапазону. Функции находятся в отдельном модуле.
Функции проверки принадлежности кода к заданному диапазону:
'КодоваятаблицаКОИ-8R
Function cp1(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim e As Boolean, d As Boolean
Const x1 = 163, X2 = 179
Const x4 = 195, X5 = 255
a = x1 = kod: b = X2 = kod
d = x4
cp1 = (a) Or (b) Or (d And e)
End Function
'КодоваятаблицаCp1251
Function cp2(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 168, X2 = 184
Const x3 = 195, x4 = 255
a = x1 = kod: b = kod = X2
c = x3
cp2 = (a) Or (b) Or (c And d)
End Function
'КодоваятаблицаOEM
Function cp3(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Dim a1 As Boolean, b1 As Boolean
Dim c1 As Boolean, d1 As Boolean
Dim a2 As Boolean, b2 As Boolean
Dim c2 As Boolean, d2 As Boolean
Dim a3 As Boolean, b3 As Boolean
Dim c3 As Boolean, d3 As Boolean
Dim a4 As Boolean, b4 As Boolean
Dim c4 As Boolean, d4 As Boolean
Const x1 = 132, X2 = 133
Const x3 = 156, x4 = 159
Const X5 = 160, X6 = 173
Const X7 = 181, X8 = 184
Const X9 = 189, X10 = 190
Const X11 = 198, X12 = 199
Const X13 = 208, X14 = 216
Const X15 = 221, X16 = 222
Const X17 = 224, X18 = 238
Const X19 = 225, X20 = 252
a = x1
a1 = X5
a2 = X9
a3 = X13
a4 = X17
cp3 = (a And b) Or (c And d) Or (a1 And b1) Or (c1 And d1) Or (a2 And b2) Or (c2 And d2) Or (a3 And b3) Or (c3 And d3) Or (a4 And b4) Or (c4 And d4)
End Function
'КодоваятаблицаCp866
Function cp4(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 128, X2 = 175
Const x3 = 224, x4 = 241
a = x1
c = x3
cp4 = (a And b) Or (c And d)
End Function
'КодоваятаблицаMac
Function cp5(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 128, X2 = 159
Const x3 = 221, x4 = 254
a = x1
c = x3
cp5 = (a And b) Or (c And d) продолжение
--PAGE_BREAK--
End Function
'КодоваятаблицаISO
Function cp6(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 160, X2 = 240
Const x3 = 176, x4 = 238
a = x1 = kod: b = kod = X2
c = x3
cp6 = (a And b) Or (c And d)
End Function
'Кодовая таблица Unicode (младшие разряды)
Function cp7(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 1, X2 = 81
Const x3 = 16, x4 = 79
a = x1 = kod: b = kod = X2
c = x3
cp7 = a Or b Or (c And d)
End Function
'Продолжение Unicode (старшие разряды(04))
Function cp71(symb As String) As Boolean
Dim k As Byte
Dim a As Boolean
Const x1 = 4
k = AscB(symb)
a = x1 = k
cp71 = a
End Function
Алгоритмы перекодировки файла в cp1251
Зная кодировку (п.2) можно составить алгоритм перекодировки текста исходной кодировки в заданную-ср1251. Мною были выбраны шесть кодовых таблиц: КОИ-8R, OEM, cp866, ISO, MAC и Unicode.
С первыми пятью кодировками все просто:
Выбрать из строки поочередно каждый символ.
Определить код символа заданной кодировки.
Добавить (отнять) к коду разницу от кода такого же символа в кодировке 1251.
Определить символ по полученному новому коду.
Добавить полученный символ в новую строку.
Подпрограмма выбора варианта перекодировки (КОИ-8R, 1251, OEM, 866, MAC, Unicode):
Sub Decoder(Fmas() As String, IndxCP As Integer, r As Integer, Smas() As String)
Dim i As Integer
Dim n As Integer
Dim Stroka As String
Dim OutStr As String
Dim smb As String
Dim code As Byte
If IndxCP = 1 Then Exit Sub 'если кодировка cp1251, то выход из процедуры без перекодирования
If IndxCP = 6 Then
Call DecUnicodeTo1251(Fmas, Smas)
Exit Sub
End If
ReDim Smas(r — 1)
For i = 0 To r — 1
Stroka = Fmas(i)
OutStr = ""
For n = 1 To Len(Stroka)
smb = Mid(Stroka, n, 1)
code = Asc(smb)
Select Case IndxCP
Case 0
OutStr = OutStr & Chr(cpKoiTo1251(code))
Case 2
OutStr = OutStr & Chr(cpOEMTo1251(code))
Case 3
OutStr = OutStr & Chr(cp866To1251(code))
Case 4
OutStr = OutStr & Chr(cpMACTo1251(code))
Case 5
OutStr = OutStr & Chr(cpISOTo1251(code))
End Select
Next n
Smas(i) = OutStr
Next i
End Sub
С Unicode немного сложнее:
В начало текста (Unicode) добавляется два символа «я» и «ю». Их нужно удалить.
Перекодировать нужно только первый байт, во втором байте всегда 04.
Символы такие как «точка», «запятая» и другие, кодируются в памяти двумя байтами, но второй байт будет пустой.
Выбрать из строки поочередно каждый символ и определить его код.
Выбрать следующий за ним символ и определить его код.
Если первый байт не равен 4, а второй байт равен 4, то первый байт Unicode перекодируется в cp1251.
Иначе если первый байт не равен 4 и второй байт не равен 4, то перекодировка не требуется.
Добавить полученный символ в новую строку.
Подпрограмма обработки текста кодированного в Unicode для перекодировки в cp1251:
Sub DecUnicodeTo1251(TextUnicode() As String, Text1251() As String)
Dim i As Integer
Dim n As Integer
Dim fstr As String
Dim smb1 As String * 1
Dim smb2 As String * 1
Dim code1 As Byte
Dim code2 As Byte
Dim OutStr As String
'В тексте кодированном в cpUnicode в начале добавляется два символа «ю» и «я»
'Поэтому их надо удалить
fstr = Right(TextUnicode(0), Len(TextUnicode(0)) — 2) 'удаление символов «ю» и «я»
TextUnicode(0) = fstr
For i = 0 To UBound(TextUnicode)
OutStr = ""
For n = 1 To Len(TextUnicode(i))
smb1 = Mid(TextUnicode(i), n, 1)
code1 = Asc(smb1) продолжение
--PAGE_BREAK--
smb2 = Mid(TextUnicode(i), n + 1, 1)
code2 = Asc(smb2)
'Проверка по двум байтам:
'Если второй байт равен 4, то первый байт Unicode перекодируется в cp1251
If (code1 4 And code2 = 4) Then OutStr = OutStr & Chr(cpUnicodeTo1251(code1))
'Если первый байт не равен 4, то символ ASCII, и не требует перекодировки
If (code1 4 And code2 4) Then OutStr = OutStr & Chr(code1)
Next n
ReDim Preserve Text1251(i)
Text1251(i) = OutStr
Next i
End Sub
Функции перекодировки кода заданной кодировки в код ср1251:
'перекодирование кода символа из cpКОИ-8R в cp1251
Function cpKoiTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 225 To 226
c = code — 33
Case 228 To 229
c = code — 32
Case 233 To 240
c = code — 33
Case 242 To 245
c = code — 34
Case 193 To 194
c = code + 31
Case 196 To 197
c = code + 32
Case 201 To 208
c = code + 31
Case 210 To 213
c = code + 30
Case 221
c = 249
Case 223
c = 250
Case 217
c = 251
Case 216
c = 252
Case 220
c = 253
Case 192
c = 254
Case 247
c = 194
Case 231
c = 195
Case 179
c = 168
Case 246
c = 198
Case 250
c = 199
Case 230
c = 212
Case 232
c = 213
Case 227
c = 214
Case 254
c = 215
Case 251
c = 216
Case 163
c = 184
Case 214
c = 230
Case 218
c = 231
Case 198
c = 244
Case 253
c = 217
Case 255
c = 218
Case 249
c = 219
Case 248
c = 220
Case 252
c = 221
Case 224
c = 222
Case 242
c = 223
Case 215
c = 226
Case 199
c = 227
Case 195
c = 246
Case 222
c = 247
Case 219
c = 248
Case 200
c = 245
Case 209
c = 255
End Select
cpKoiTo1251 = c
End Function
'перекодирование кода символа из cpOEM в cp1251
Function cpOEMTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 161
c = 192
Case 163
c = 193
Case 236
c = 194
Case 173
c = 195
Case 167
c = 196
Case 169
c = 197
Case 133
c = 168
Case 234
c = 198
Case 244
c = 199
Case 184
c = 200
Case 190
c = 201
Case 199
c = 202
Case 209
c = 203
Case 211
c = 204
Case 213
c = 205
Case 215
c = 206
Case 221
c = 207
Case 226
c = 208
Case 228
c = 209
Case 181
c = 245
Case 164
c = 246 продолжение
--PAGE_BREAK--
Case 251
c = 247
Case 230
c = 210
Case 232
c = 211
Case 171
c = 212
Case 182
c = 213
Case 165
c = 214
Case 152
c = 215
Case 246
c = 216
Case 250
c = 217
Case 238
c = 218
Case 242
c = 219
Case 159
c = 220
Case 248
c = 221
Case 170
c = 244
Case 249
c = 249
Case 237
c = 250
Case 241
c = 251
Case 158
c = 252
Case 247
c = 253
Case 150
c = 254
Case 222
c = 255
Case 231
c = 243
Case 245
c = 248
Case 157
c = 222
Case 224
c = 223
Case 160
c = 224
Case 162
c = 225
Case 235
c = 226
Case 172
c = 227
Case 166
c = 228
Case 168
c = 229
Case 132
c = 184
Case 233
c = 230
Case 243
c = 231
Case 183
c = 232
Case 189
c = 233
Case 198
c = 234
Case 208
c = 235
Case 210
c = 236
Case 212
c = 237
Case 214
c = 238
Case 216
c = 239
Case 225
c = 240
Case 227
c = 241
Case 229
c = 242
End Select
cpOEMTo1251 = c
End Function
'перекодирование кода символа из cp866 в cp1251
Function cp866To1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 128 To 175
c = code + 64
Case 224 To 239
c = code + 16
Case 240
c = 168
Case 241
c = 184
End Select
cp866To1251 = c
End Function
'перекодирование кода символа из Unicode в cp1251
Function cpUnicodeTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 16 To 79
c = code + 176
Case 1
c = 168
Case 81
c = 184
End Select
cpUnicodeTo1251 = c
End Function
'перекодирование кода символа из cpMAC в cp1251
Function cpMACTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 128 To 159
c = code + 64
Case 224 To 254
c = code
Case 221
c = 168
Case 222
c = 184
Case 223
c = 255
End Select
cpMACTo1251 = c
End Function
'перекодирование кода символа из cpISO в cp1251
Function cpISOTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 176 To 239 продолжение
--PAGE_BREAK--
c = code + 16
Case 160
c = 168
Case 240
c = 184
End Select
cpISOTo1251 = c
End Function
Алгоритм сортировки записей исходного файла
Задача сортировки файла формулируется следующим образом. Имеется файл, состоящий из последовательности записей. Одно из полей в составе каждой записи является полем ключа. Файл целиком размещается во внутренней памяти. Требуется вывести файл на внешний носитель так, чтобы записи располагались в заданном порядке следования ключей.
Из возможного множества алгоритмов сортировки файлов более эффективными будут те, которые требуют меньше перестановок записей. В работе рассматривается такой алгоритм, который вообще не требует ни одной перестановки: после подготовительных процедур записи выводятся в файл в заданном порядке следования ключей.
Данное, которое находится в составе записи и значения, которого должны учитываться при сортировке, называется ключом.
Для сортировки записей по заданному ключевому полю удобнее использовать ЗАПИСИ:
Первые две строки файла – заголовок и «Шапка» в сортировке не участвуют.
Третья и последующие строки преобразуются в ЗАПИСИ типа param:
Type param
prop As String
vol(7) As Single
End Type
Например:
ЗАПИСЬ:
Par.prop
Par.vol(0)
Par.vol(1)
Par.vol(2)
Par.vol(3)
Строка:
Аммиак NH3
15,0
28,0
15
79
Разделителем при преобразовании в ЗАПИСЬ является знак горизонтальной табуляции (HT)
Например:
Аммиак NH3HT15,0HT28,0HT15HT79
Подпрограмма разделения строк исходного файла на поля:
Sub seps(str As String, par As param, howpar As Integer)
Dim p As Integer, q As Integer, r As Integer
Dim dlina As Integer
Dim sp As String, smb As String
Dim HT As String * 1
HT = Chr(9)
dlina = Len(str)
If dlina = 0 Then
Exit Sub
End If
r = InStr(str, HT)
par.prop = Left(str, r — 1)
sp = Right(str, dlina — r) & HT
dlina = dlina — r + 1
p = 1: q = 0
Do While p
r = InStr(p, sp, HT)
smb = Mid(sp, p, r — p)
If smb = "-" Then
par.vol(q) = 0
Else:
par.vol(q) = CSng(smb)
End If
q = q + 1
p = r + 1
Loop
howpar = q
End Sub
Алгоритмсортировки
Решение задачи сортировки файла разбивается на два этапа.
На первом этапе создаётся вспомогательный вектор. На втором этапе формируется выходной файл: первой выводится запись, номер которой 0 затем выводится запись, номер которой 1 и т. д.
Первый этап. Описание алгоритма формирования вспомогательного вектора.
Исходные данные: volVector — массив записей, в составе каждой записи имеется поле ключа Vol(1). В массиве volVector содержится N элементов. доступ к ключу j-ого элемента обозначается так: volVector(j).Vol(1). Тип данного Vol(1) допускает сравнение на равно, больше и меньше. В результате выполнения алгоритма, определяются значения элементов вспомогательного вектора intMesto. В алгоритме используется вспомогательный логический вектор размером N. flag(j)=True обозначает, что элемент volVector(j) доступен для просмотра, но, если flag(j)=False, то элемент volVector(j) исключается из просмотра. В исходном состоянии все элементы вектора flag устанавливаются в значение True. Вспомогательная переменная voltemp хранит текущее минимальное значение Vol(1). Константа voltemp имеет тот же тип, что и ключ Vol(1), значение voltemp заведомо больше любого ключа Vol(1).
1. Для каждого i от 0 до N выполнять шаги 1....5. (Индекс i определяет место записи в выходном файле.)
2. Установить voltemp равным 99999 и перейти к шагу 3.
3. Для каждого j от 0 до N выполнять шаг 4. (В этом цикле отыскивается претендент на место i.)
4. Если flag(j)=True и volVector(j).Vol(1)
5. ВыполнитьintMesto(i)←kl; flag(kl)←False. (Минимальное значение из множества доступных ключей найдено в записи с индексом kl. Значение kl записывается в intMesto(i), kl-ый элемент вектора volVector помечается как недоступный, исключается из дальнейших действий.)
Второй этап сортировки файла — вывод в рабочий лист Excel и запись в файл на диске.
(mas-массив исходных записей, mm-вспомогательный массив, sk-массив исходных строк) продолжение
--PAGE_BREAK--
For q = 0 To h
Cells(q + 3, 1) = mas(mm(q)).prop
For i = 0 To hp — 1
Cells(q + 3, i + 2) = mas(mm(q)).vol(i)
Next i
Print #nf2, sk(mm(q) + 2)
Next q
Подпрограмма первого этапа сортировки (создание вспомогательного массива intMesto):
Sub sort(volVector() As param, intMesto() As Integer, h As Integer)
Dim i As Integer, j As Integer, kl As Integer
Dim highIndex As Integer, lj As Integer
Dim voltemp As Single
Dim flag() As Boolean
h = UBound(volVector)
ReDim intMesto(h)
highIndex = UBound(volVector)
ReDim flag(highIndex)
For i = 0 To highIndex
flag(i) = True
Next i
For i = 0 To highIndex
voltemp = 99999
For j = 0 To highIndex
If flag(j) Then
If volVector(j).vol(1)
'если volvector(j) будет меньше или равно voltemp
'то значение текущего минимума voltemp, будет
'заменено на элемент volvector(j)
voltemp = volVector(j).vol(1)
kl = j
End If
End If
Next j
intMesto(i) = kl
flag(kl) = False
Next i
End Sub
Подпрограмма второго этапа сортировки — вывод результата в рабочий лист Excelи запись в файл на диске:
Sub OutputData(name As String, sk() As String, mm() As Integer, h As Integer, hp As Integer, nf2 As Integer, str As String, mas() As param)
Dim i As Integer, q As Integer
Open name For Output As nf2
Print #nf2, sk(0)
Print #nf2, sk(1)
Cells(1, 1) = sk(0)
For i = 0 To hp
Cells(2, i + 1) = str(i)
Next i
For q = 0 To h
Cells(q + 3, 1) = mas(mm(q)).prop
For i = 0 To hp — 1
Cells(q + 3, i + 2) = mas(mm(q)).vol(i)
Next i
Print #nf2, sk(mm(q) + 2)
Next q
Close #nf2
End Sub
5. Структурная иерархическая схема программы
6. Листинг программы
Модуль 1
Главная программа
'Главная программа
'Чалков С.А. 10.06.2010
Sub Core()
Dim st() As String, sk() As String
Dim mm() As Integer, mas() As param
Dim h As Integer, кодировкаAs String
Dim msg As String
Dim q As Integer, hp As Integer
Dim nf1 As Integer, nf2 As Integer
Dim k As Integer, i As Integer
Dim str As String, indx As Integer
Dim name1 As String, name2 As String
name1 = «d:\ВоспламеняемостьГазов.txt»
name2 = «d:\vba\Save.txt»
nf1 = FreeFile(): nf2 = FreeFile()
Worksheets(1).Select
Call InputData(name1, nf1, st, sk, k)
Call FindCP(st, кодировка, msg, indx): MsgBox кодировка: MsgBox msg
Call Decoder(st, indx, k, sk)
Call ConvertToRecord(sk, k, str, mas, hp)
Call sort(mas, mm, h)
Call OutputData(name2, sk, mm, h, hp, nf2, str, mas)
End Sub
Модуль 2
Ввод данных из файла в память
Sub InputData(name As String, nf1 As Integer, st() As String, sk() As String, k As Integer)
k = 0
Open name For Input As nf1
Do Until EOF(nf1)
ReDim Preserve st(k)
Line Input #nf1, st(k)
ReDim Preserve sk(k)
sk(k) = st(k)
k = k + 1
Loop продолжение
--PAGE_BREAK--
Close #nf1
End Sub
Модуль 3
Проверка принадлежности текста к одной из шести кодовых таблиц
Sub FindCP(stroky() As String, msg1 As String, msg2 As String, index As Integer)
Dim s As Integer, z As Integer
Dim symb As String * 1
Dim kod As Byte
Dim scp(7) As codepage
Dim ks As String, ks1 As String
Dim ks2 As String, ne As String
ks = «Ваш текст предположительно имеет кодировку „
ne = “не „
ks1 = “Требуется „
ks2 = “Перекодировка „
For s = 0 To UBound(stroky)
For z = 1 To Len(stroky(s))
symb = Mid(stroky(s), z, 1)
kod = Asc(symb)
If cp1(kod) Then scp(0).vol = scp(0).vol + 1: scp(0).name = “КОИ-8R»
If cp2(kod) Then scp(1).vol = scp(1).vol + 1: scp(1).name = «Cp1251»
If cp3(kod) Then scp(2).vol = scp(2).vol + 1: scp(2).name = «OEM»
If cp4(kod) Then scp(3).vol = scp(3).vol + 1: scp(3).name = «Cp866»
If cp5(kod) Then scp(4).vol = scp(4).vol + 1: scp(4).name = «Mac»
If cp6(kod) Then scp(5).vol = scp(5).vol + 1: scp(5).name = «ISO»
If cp71(symb) Then scp(6).vol = scp(6).vol + 1: scp(6).name = «Unicode»
Next z
Next s
z = 0
For s = 0 To 6
If scp(s).vol >= z Then
z = scp(s).vol: index = s
End If
Next s
'При совпадении счетчиков «КОИ-8R» и "cp1251" кодировка текста определяется как "cp1251"
If ((scp(0).vol = scp(1).vol) And index
If index = 1 Then
msg1 = ks & scp(index).name
msg2 = ks2 & ne & LCase(ks1)
Else:
msg1 = ks & scp(index).name
msg2 = ks1 & LCase(ks2)
End If
End Sub
Модуль 4
Процедура выбора варианта перекодировки (КОИ-8R, 1251, OEM, 866, MAC, Unicode)
Sub Decoder(Fmas() As String, IndxCP As Integer, r As Integer, Smas() As String)
Dim i As Integer
Dim n As Integer
Dim Stroka As String
Dim OutStr As String
Dim smb As String
Dim code As Byte
If IndxCP = 1 Then Exit Sub 'если кодировка cp1251, то выход из процедуры без перекодирования
If IndxCP = 6 Then
Call DecUnicodeTo1251(Fmas, Smas)
Exit Sub
End If
ReDim Smas(r — 1)
For i = 0 To r — 1
Stroka = Fmas(i)
OutStr = ""
For n = 1 To Len(Stroka)
smb = Mid(Stroka, n, 1)
code = Asc(smb)
Select Case IndxCP
Case 0
OutStr = OutStr & Chr(cpKoiTo1251(code))
Case 2
OutStr = OutStr & Chr(cpOEMTo1251(code))
Case 3
OutStr = OutStr & Chr(cp866To1251(code))
Case 4
OutStr = OutStr & Chr(cpMACTo1251(code))
Case 5
OutStr = OutStr & Chr(cpISOTo1251(code))
End Select
Next n
Smas(i) = OutStr
Next i
End Sub
Модуль5
Проверка необходимости преобразования строк в записи пользовательского типа
Sub ConvertToRecord(sk() As String, k As Integer, str As shapka, mas() As param, hp As Integer)
Dim i As Integer
Dim str1 As String
Dim str2 As param
For i = 1 To k — 1
str1 = sk(i)
If i = 1 Then
Call sep(str1, str, hp)
Else:
If k > 1 Then
Call seps(str1, str2, hp)
ReDim Preserve mas(i — 2)
mas(i — 2) = str2
End If
End If
Next i
End Sub
Модуль 6
Первый этап сортировки строк (создание вспомогательного массива)
Sub sort(volVector() As param, intMesto() As Integer, h As Integer)
Dim i As Integer, j As Integer, kl As Integer
Dim highIndex As Integer, lj As Integer продолжение
--PAGE_BREAK--
Dim voltemp As Single
Dim flag() As Boolean
h = UBound(volVector)
ReDim intMesto(h)
highIndex = UBound(volVector)
ReDim flag(highIndex)
For i = 0 To highIndex
flag(i) = True
Next i
For i = 0 To highIndex
voltemp = 99999
For j = 0 To highIndex
If flag(j) Then
If volVector(j).vol(1)
'то значение текущего минимума voltemp, будет
'заменено на элемент volvector(j)
voltemp = volVector(j).vol(1)
kl = j
End If
End If
Next j
intMesto(i) = kl
flag(kl) = False
Next i
End Sub
Модуль7
Вывод результата на рабочий лист Excel и сохранение в файл
Sub OutputData(name As String, sk() As String, mm() As Integer, h As Integer, hp As Integer, nf2 As Integer, str As String, mas() As param)
Dim i As Integer, q As Integer
Open name For Output As nf2
Print #nf2, sk(0)
Print #nf2, sk(1)
Cells(1, 1) = sk(0)
For i = 0 To hp
Cells(2, i + 1) = str(i)
Next i
For q = 0 To h
Cells(q + 3, 1) = mas(mm(q)).prop
For i = 0 To hp — 1
Cells(q + 3, i + 2) = mas(mm(q)).vol(i)
Next i
Print #nf2, sk(mm(q) + 2)
Next q
Close #nf2
End Sub
Модуль 8
Процедура обработки текста кодированного в cpUnicode для перекодировки в cp1251
Sub DecUnicodeTo1251(TextUnicode() As String, Text1251() As String)
Dim i As Integer
Dim n As Integer
Dim fstr As String
Dim smb1 As String * 1
Dim smb2 As String * 1
Dim code1 As Byte
Dim code2 As Byte
Dim OutStr As String
'В тексте кодированном в cpUnicode в начале добавляется два символа «ю» и «я»
'Поэтому их надо удалить
fstr = Right(TextUnicode(0), Len(TextUnicode(0)) — 2) 'удаление символов «ю» и «я»
TextUnicode(0) = fstr
For i = 0 To UBound(TextUnicode)
OutStr = ""
For n = 1 To Len(TextUnicode(i))
smb1 = Mid(TextUnicode(i), n, 1)
code1 = Asc(smb1)
smb2 = Mid(TextUnicode(i), n + 1, 1)
code2 = Asc(smb2)
'Проверка по двум байтам:
'Если второй байт равен 4, то первый байт Unicode перекодируется в cp1251
If (code1 4 And code2 = 4) Then OutStr = OutStr & Chr(cpUnicodeTo1251(code1))
'Если первый байт не равен 4, то символ ASCII, и не требует перекодировки
If (code1 4 And code2 4) Then OutStr = OutStr & Chr(code1)
Next n
ReDim Preserve Text1251(i)
Text1251(i) = OutStr
Next i
End Sub
Модуль9
Диапазоныкодовкодировок(КОИ-8R, 1251, OEM, 866, MAC, Unicode)
'КодоваятаблицаКОИ-8R
Function cp1(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim e As Boolean, d As Boolean
Const x1 = 163, X2 = 179
Const x4 = 195, X5 = 255
a = x1 = kod: b = X2 = kod
d = x4
cp1 = (a) Or (b) Or (d And e)
End Function
'КодоваятаблицаCp1251
Function cp2(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 168, X2 = 184
Const x3 = 195, x4 = 255
a = x1 = kod: b = kod = X2
c = x3
cp2 = (a) Or (b) Or (c And d)
End Function
'КодоваятаблицаOEM
Function cp3(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Dim a1 As Boolean, b1 As Boolean
Dim c1 As Boolean, d1 As Boolean
Dim a2 As Boolean, b2 As Boolean продолжение
--PAGE_BREAK--
Dim c2 As Boolean, d2 As Boolean
Dim a3 As Boolean, b3 As Boolean
Dim c3 As Boolean, d3 As Boolean
Dim a4 As Boolean, b4 As Boolean
Dim c4 As Boolean, d4 As Boolean
Const x1 = 132, X2 = 133
Const x3 = 156, x4 = 159
Const X5 = 160, X6 = 173
Const X7 = 181, X8 = 184
Const X9 = 189, X10 = 190
Const X11 = 198, X12 = 199
Const X13 = 208, X14 = 216
Const X15 = 221, X16 = 222
Const X17 = 224, X18 = 238
Const X19 = 225, X20 = 252
a = x1
a1 = X5
a2 = X9
a3 = X13
a4 = X17
cp3 = (a And b) Or (c And d) Or (a1 And b1) Or (c1 And d1) Or (a2 And b2) Or (c2 And d2) Or (a3 And b3) Or (c3 And d3) Or (a4 And b4) Or (c4 And d4)
End Function
'КодоваятаблицаCp866
Function cp4(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 128, X2 = 175
Const x3 = 224, x4 = 241
a = x1
c = x3
cp4 = (a And b) Or (c And d)
End Function
'КодоваятаблицаMac
Function cp5(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 128, X2 = 159
Const x3 = 221, x4 = 254
a = x1
c = x3
cp5 = (a And b) Or (c And d)
End Function
'КодоваятаблицаISO
Function cp6(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 160, X2 = 240
Const x3 = 176, x4 = 238
a = x1 = kod: b = kod = X2
c = x3
cp6 = (a And b) Or (c And d)
End Function
'Кодовая таблица Unicode (младшие разряды)
Function cp7(kod As Byte) As Boolean
Dim a As Boolean, b As Boolean
Dim c As Boolean, d As Boolean
Const x1 = 1, X2 = 81
Const x3 = 16, x4 = 79
a = x1 = kod: b = kod = X2
c = x3
cp7 = a Or b Or (c And d)
End Function
'Продолжение Unicode (старшие разряды(04))
Function cp71(symb As String) As Boolean
Dim k As Byte
Dim a As Boolean
Const x1 = 4
k = AscB(symb)
a = x1 = k
cp71 = a
End Function
Модуль 10
Описание пользовательских типов данных
Type param
prop As String
vol(7) As Single
End Type
Type codepage
name As String
vol As Integer
End Type
Модуль11
Процедура разбивки строки на слова с последующей записью в массив
Sub sep(str As String, par() As String, howpar As Integer)
Dim p As Integer, q As Integer, r As Integer
Dim dlina As Integer
Dim sp As String
Dim slovo As String
Dim HT As String * 1
HT = Chr(9) '09-код символа «горизонтальная табуляция»
str = str & HT
dlina = Len(str)
p = 1: q = 0
Do While p
r = InStr(p, str, HT)
slovo = Mid(str, p, r — p)
ReDim Preserve par(q)
par(q) = slovo
q = q + 1
p = r + 1
Loop
howpar = q
End Sub
Модуль 12
Процедура преобразования строки в запись(элементы записи могут быть типа String и Single)
Sub seps(str As String, par As param, howpar As Integer)
Dim p As Integer, q As Integer, r As Integer продолжение
--PAGE_BREAK--
Dim dlina As Integer
Dim sp As String, smb As String
Dim HT As String * 1
HT = Chr(9)
dlina = Len(str)
If dlina = 0 Then
Exit Sub
End If
r = InStr(str, HT)
par.prop = Left(str, r — 1)
sp = Right(str, dlina — r) & HT
dlina = dlina — r + 1
p = 1: q = 0
Do While p
r = InStr(p, sp, HT)
smb = Mid(sp, p, r — p)
If smb = "-" Then
par.vol(q) = 0
Else:
par.vol(q) = CSng(smb)
End If
q = q + 1
p = r + 1
Loop
howpar = q
End Sub
Модуль13
Перекодирование кодов символов из исходной кодировки в заданную 1251
'Перекодирование кода символа из cpКОИ-8R в cp1251
Function cpKoiTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 225 To 226
c = code — 33
Case 228 To 229
c = code — 32
Case 233 To 240
c = code — 33
Case 242 To 245
c = code — 34
Case 193 To 194
c = code + 31
Case 196 To 197
c = code + 32
Case 201 To 208
c = code + 31
Case 210 To 213
c = code + 30
Case 253
c = 217
Case 255
c = 218
Case 249
c = 219
Case 247
c = 194
Case 231
c = 195
Case 179
c = 168
Case 246
c = 198
Case 250
c = 199
Case 230
c = 212
Case 232
c = 213
Case 227
c = 214
Case 254
c = 215
Case 251
c = 216
Case 224
c = 222
Case 163
c = 184
Case 214
c = 230
Case 218
c = 231
Case 198
c = 244
Case 200
c = 245
Case 195
c = 246
Case 222
c = 247
Case 219
c = 248
Case 221
c = 249
Case 223
c = 250
Case 252
c = 221
Case 242
c = 223
Case 215
c = 226
Case 199
c = 227
Case 209
c = 255
Case 217
c = 251
Case 216
c = 252
Case 220
c = 253
Case 192
c = 254
Case 248
c = 220
End Select
cpKoiTo1251 = c
End Function
'перекодирование кода символа из cpOEM в cp1251
Function cpOEMTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 161
c = 192
Case 163
c = 193
Case 236
c = 194
Case 173
c = 195
Case 167
c = 196
Case 169
c = 197
Case 133
c = 168
Case 234
c = 198
Case 244
c = 199
Case 184
c = 200
Case 190
c = 201 продолжение
--PAGE_BREAK--
Case 199
c = 202
Case 209
c = 203
Case 211
c = 204
Case 213
c = 205
Case 215
c = 206
Case 221
c = 207
Case 229
c = 242
Case 231
c = 243
Case 170
c = 244
Case 181
c = 245
Case 164
c = 246
Case 251
c = 247
Case 245
c = 248
Case 249
c = 249
Case 237
c = 250
Case 241
c = 251
Case 158
c = 252
Case 247
c = 253
Case 150
c = 254
Case 222
c = 255
Case 232
c = 211
Case 171
c = 212
Case 226
c = 208
Case 168
c = 229
Case 132
c = 184
Case 233
c = 230
Case 243
c = 231
Case 183
c = 232
Case 189
c = 233
Case 198
c = 234
Case 208
c = 235
Case 210
c = 236
Case 212
c = 237
Case 214
c = 238
Case 216
c = 239
Case 225
c = 240
Case 227
c = 241
Case 228
c = 209
Case 230
c = 210
Case 166
c = 228
Case 182
c = 213
Case 165
c = 214
Case 152
c = 215
Case 246
c = 216
Case 250
c = 217
Case 238
c = 218
Case 242
c = 219
Case 159
c = 220
Case 248
c = 221
Case 157
c = 222
Case 224
c = 223
Case 160
c = 224
Case 162
c = 225
Case 235
c = 226
Case 172
c = 227
End Select
cpOEMTo1251 = c
End Function
'перекодирование кода символа из cp866 в cp1251
Function cp866To1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 128 To 175
c = code + 64
Case 224 To 239
c = code + 16
Case 240
c = 168
Case 241
c = 184
End Select
cp866To1251 = c
End Function
'перекодирование кода символа из Unicode в cp1251
Function cpUnicodeTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 16 To 79
c = code + 176
Case 1
c = 168
Case 81
c = 184
End Select
cpUnicodeTo1251 = c
End Function
'перекодирование кода символа из cpMAC в cp1251
Function cpMACTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 128 To 159
c = code + 64
Case 224 To 254
c = code
Case 221
c = 168
Case 222
c = 184
Case 223
c = 255
End Select
cpMACTo1251 = c
End Function
'перекодирование кода символа из cpISO в cp1251
Function cpISOTo1251(code As Byte) As Byte
Dim c As Byte
c = code
Select Case code
Case 176 To 239
c = code + 16
Case 160
c = 168
Case 240
c = 184
End Select
cpISOTo1251 = c
End Function
Литература
Стеценко А.А. Структуры и алгоритмы обработки данных – Методические указания к практическим и лабораторным занятиям.: Чебоксары 2009.
Стеценко А.А. Структуры и типы данных – учебное пособие.: Чебоксары 2009.
Электронный учебник по VBA. Режим доступа: www.mini-soft.ru/soft/vba Ссылки (links):
www.mini-soft.ru/soft/vba