 |
Структурная иерархическая схема программы
|
|
|
|
Листинг программы
Модуль 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
|
|
|
