Перекодировка текстовых файлов

Структура заданного исходного файла и структуры данных, соответствующие данным файла



Файл – это последовательность байтов, хранящаяся в памяти.

Текстовый файл – это так же последовательность байтов, но каждый байт текстового файла можно представить кодом символа.

Заданный исходный файл – текстовый, так как в каждом байте хранится код символа.

В файле хранится текст:

Пределы воспламеняемости некоторых газов и паров в воздухе и в кислороде, % (объемы). Давление 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"

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 <= 1) Then index = 1

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 <= kod: e = kod <= X5

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 <= kod: d = kod <= x4

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 <= kod: b = kod <= X2: c = x3 <= kod: d = kod <= x4

a1 = X5 <= kod: b1 = kod <= X6: c1 = X7 <= kod: d1 = kod <= X8

a2 = X9 <= kod: b2 = kod <= X10: c2 = X11 <= kod: d2 = kod <= X12

a3 = X13 <= kod: b3 = kod <= X14: c3 = X15 <= kod: d3 = kod <= X16

a4 = X17 <= kod: b4 = kod <= X18: c4 = X19 <= kod: d4 = kod <= X20

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 <= kod: b = kod <= X2

c = x3 <= kod: d = kod <= x4

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 <= kod: b = kod <= X2

c = x3 <= kod: d = kod <= x4

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 <= kod: d = kod <= x4

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 <= kod: d = kod <= x4

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)

	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

				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

			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 < dlina

	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)<=voltemp, выполнить voltemp ← volVector(j).Vol(1); kl←j. (Если элемент volVector(j) доступен и его ключ volVector(j).Vol(1) меньше, чем текущий минимум voltemp, то заменить значение текущего минимума и запомнить его место. Доступность элемента volVector(j) определяется значением True элемента flag(j). 

	5. Выполнить intMesto(i)←kl; flag(kl)←False. (Минимальное значение из множества доступных ключей найдено в записи с индексом kl. Значение kl записывается в intMesto(i), kl-ый элемент вектора volVector помечается как недоступный, исключается из дальнейших действий.) 

	Второй этап сортировки файла - вывод в рабочий лист Excel и запись в файл на диске.

	(mas-массив исходных записей, mm-вспомогательный массив, sk-массив исходных строк)

	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) <= voltemp Then 

	 'если 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

	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 <= 1) Then index = 1

		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

		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 Then 'если 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

	Модуль 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 <= kod: e = kod <= X5

		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 <= kod: d = kod <= x4

		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 <= kod: b = kod <= X2: c = x3 <= kod: d = kod <= x4

		a1 = X5 <= kod: b1 = kod <= X6: c1 = X7 <= kod: d1 = kod <= X8

		a2 = X9 <= kod: b2 = kod <= X10: c2 = X11 <= kod: d2 = kod <= X12

		a3 = X13 <= kod: b3 = kod <= X14: c3 = X15 <= kod: d3 = kod <= X16

		a4 = X17 <= kod: b4 = kod <= X18: c4 = X19 <= kod: d4 = kod <= X20

		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 <= kod: b = kod <= X2

		c = x3 <= kod: d = kod <= x4

		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 <= kod: b = kod <= X2

		c = x3 <= kod: d = kod <= x4

		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 <= kod: d = kod <= x4

		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 <= kod: d = kod <= x4

		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 < dlina

		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

		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 < dlina

		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

		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. Режим доступа: http://www.mini-soft.ru/soft/vba





42