Помощь с курсовой работой по информатике для ТулГУ, пример оформления

Курсовая работа по дисциплине «Информатика» Вариант №9 9.1. Вычислить площадь и сторону по заданной величине радиуса окружности, вписанной в правильный треугольник r = 5,125м. Написать универсальную подпрограмму, решающую данную задачу для произвольных значений параметра r. Решение: По определенным формулам необходимо получить некоторое число. При написании универсальной подпрограммы желательно проконтролировать правильность ввода исходных данных и предусмотреть различные варианты данных. В данной задаче необходимо применить следующие формулы из планиметрии: L=(a∙3)/√3 S=3∙√3∙a^2 Sub Вариант09Задача1() Dim a As Double, L As Double, S As Double Dim Res As String beg: ‘Метка начала ввода данных a = Val(InputBox(«Введите радиус a», , «5,125»)) ‘Ввод радиуса вписанной окружности If a < 0 Then Res = MsgBox("Повторите ввод", vbCritical + vbYesNo + vbDefaultButton1) If Res = vbYes Then GoTo beg Else Exit Sub End If L = ДлинаСтороныТреугольника(a) S = ПлощадьТреугольника(a) MsgBox ("Площадь треугольника равна " + Format(S, "# ##0.000") + Chr(13) + _ "Сторона треугольника равна " + Format(L, "# ##0.000")) End Sub Function ДлинаСтороныТреугольника(a As Double) As Double Dim L As Double L = (a * 6) / Sqr(3) 'Длина стороны ДлинаСтороныТреугольника = L End Function Function ПлощадьТреугольника(a As Double) As Double Dim S As Double S = 3 * Sqr(3) * a * a 'Площадь ПлощадьТреугольника = S End Function Рис.1.1. Вывод программы Вариант9Задача1() 9. 2. Провести вычисления по формулам: Решение: В этой задаче необходимо вычислить две математические переменные, а затем в зависимости от их значений, вычислить третью переменную по одной из двух формул. Sub Вариант09Задача2() Dim alpha As Double, beta As Double, gamma As Double, f As String f = "# ##0.0000" 'Формат вывода результатов alpha = sqra(5, ((25 + sqra(7, 36))) / (0.34 * (1 / 10) ^ 10)) beta = Atn(Cos(Pi / 3) + Cos((2 * Pi) / 5)) * Log(5) 'По какой из двух формул вычислять алгебраическое выражение If 2 * Abs(alpha) < beta Then _ gamma = ((1 / Exp(1)) ^ alpha + (1 / Exp(1)) ^ beta) / (2 * Abs(alpha) + 3 * Abs(beta)) Else _ gamma = alpha + beta Debug.Print "alpha ="; Format(alpha, f); "; beta = "; Format(beta, f); _ "; gamma ="; Format(gamma, f); "." End Sub 'Реализация функции sqra x. (Корень степени a от x) Function sqra(a As Double, x As Double) As Double sqra = x ^ (1 / a) End Function Результат работы программы: alpha = 239,2787; beta = 1,7819; gamma = 241,0605. 9.3. Написать программу, которая во вводимой с клавиатуры последовательности, состоящей из 20 действительных чисел, "отбрасывает" последнюю цифру в целой части числа. Вывести обе последовательности. Решение: Для правильной обработки цифр дробной части применяем следующий метод: Дробную часть записать в целую переменную типа Long, а затем при помощи арифметической операции целочисленного деления \ получать необходимые цифры. Для получения дробной части числа a используем следующую формулу: b = |a|-Int(|a|), где b - дробная часть числа a. Sub Вариант09Задача3() Dim a As Double, S As Double, k As Integer, i As Integer Sheets("Лист1").Select 'Перейти на рабочий лист Range("a1:b20").Clear 'Очистить область вывода данных k = 0 'Счетчик элементов последовательности b For i = 1 To 20 a = Val(InputBox("Введите a(" + Trim(Str(i)) + ")")) S = funReduceNumber(a) 'Вызываем функцию Cells(i, 1) = a Cells(i, 2) = S 'Уменьшенное число Next i End Sub Function funReduceNumber(a As Double) As Double Dim b As Long, c As Double, S As Double 'Сохраняем десятичную часть c = a - Int(a) b = Int(a) \ 10 'Отбрасываем последнюю цифру S = b + c funReduceNumber = S End Function Результаты работы программы 9.4. При помощи датчика случайных чисел вводится последовательность {ai}, состоящая из N (случайное трехзначное число) целых положительных случайных четырехзначных чисел. Получить подпоследовательность {bi}, куда включить только те элементы, в которых третья цифра нечетная. Обе последовательности вывести в соседние столбцы рабочего листа. Решение: Sub Вариант09Задача4() Dim a As Long, b As Long, N As Integer, i As Integer, k As Integer Randomize Timer N = Rnd * 899 + 100 'Трехначное случайное число k = 0 'Счетчик количества чисел удовлетворяющих условию задачи Sheets("Лист2").Select 'Перейти на рабочий лист с именем Лист2 Range("a1:b1000").Clear 'Очистить область вывода For i = 1 To N a = Int(Rnd * 8999 + 1000) 'Получаем случайное четырехзначное число Cells(i, 1) = a 'Выводим его в первый столбец 'Проверяем, нечетная ли третья цифра If funIs3NumOdd(a) Then k = k + 1 'Если цифра нечетная, то увеличиваем счетчик k на 1 Cells(k, 2) = a 'и записываем число a во второй столбец End If Next i End Sub Function funIs3NumOdd(a As Long) As Boolean Dim b As Long, c As Long 'Получаем последние 2 цифры b = a Mod 100 с = b \ 10 'Отбрасываем последнюю цифру If с Mod 2 = 0 Then ' проверяем, третье число четное или нечетное funIs3NumOdd = False Else funIs3NumOdd = True End If End Function Результат работы программы: 9.5. В одномерный массив A размерности N при помощи датчика случайных чисел вводятся действительные числа в диапазоне от -400 до 2500 (N ввести с клавиатуры). Вывести их в строку рабочего листа. Все те числа, которые больше среднеарифметического значения массива, и в которых целая часть является простым числом, выделить цветом. Решение: В данном примере числовую последовательность необходимо вначале проанализировать, а затем преобразовать. Поэтому на первом этапе ее необходимо получить и запомнить в массиве A. На первом же этапе можно еще получить и сумму элементов всего массива. На втором этапе проходим по всем элементам и проверяем больше ли число среднеарифметического значения массива и является ли целая часть простым числом. Sub Вариант09Задача5() Dim a() As Double, N As Integer, xsr As Long Dim min As Integer, i As Integer, beg As Integer, j As Integer Sheets("Лист3").Select N = Val(InputBox("Введите число элементов")) 'Создать динамический массив a, состоящий из N элементов ReDim a(N) 'Отвести по 2*N байт памяти под массив a xsr = 0 'Здесь накапливаем сумму элементов массива a Range("a1:" + БукваСтолбца(N) + "1").Clear 'Очистить область "a1:N1" For i = 1 To N 'При помощи датчика случайных чисел получить массив a a(i) = ((Rnd * 290000) - 40000) / 100 'Случайное действительное число от -400 до 2500 xsr = xsr + a(i) 'Накопить сумму элементов массива a Cells(1, i) = a(i) 'Вывести массив в первый столбец Next i xsr = Int(xsr / N + 0.5) 'Вычислить среднее значение элементов массива MsgBox (" Среднее значение=" + Str(xsr)) For i = 1 To N 'Цикл по всем элементам массива If a(i) > xsr And Простое(Int(a(i))) Then ‘Встретили элемент массива, больший среднеарифметического ‘ и у которого целая часть простое число ‘Обходим по всем ячейкам, в которых содержимое > xsr и выделяем их цветом Cells(1, i).Interior.Color = &H1100FF End If Next i End Sub Function БукваСтолбца(ByVal Col As Long) As String On Error Resume Next БукваСтолбца = Application.ConvertFormula(«r1c» & Col, xlR1C1, xlA1) БукваСтолбца = Replace(Replace(Mid(БукваСтолбца, 2), «$», «»), «1», «») End Function Function Простое(a As Long) As Boolean Dim i As Long For i = 2 To Sqr(Abs(a)) If (a Mod i) = 0 Then Простое = False: Exit Function Next i Простое = True End Function Результат работы программы: 9.6. Написать программу, которая считывает в одномерный массив A целые числа, записанные в столбце рабочего листа, начиная с выделенной ячейки. Ячейки, в которых находятся четные числа, в два раза больше минимального значения в массиве, выделить цветом. Решение: Sub Вариант09 Задача6() Dim a() As Double, b() As Double, c() As Integer, N As Integer Dim Line As Integer, alph As String, i As Integer, j As Integer Dim nb As Integer, Col As Integer, row As Integer, mn As Integer ‘В i-тый столбец рабочего листа с именем «Лист4», перед первым ‘запуском программы на выполнение, необходимо записать исходные ‘данные и установить курсор в ячейку, начиная с которой записан ‘массив Col = ActiveCell.Column ‘Номер активного столбца row = ActiveCell.row ‘Номер активной строки N = 0 ‘В этой переменной получаем количество элементов массива A ReDim a(10) ‘Отводим память под первые 10 элементов массива A Do ‘ Цикл по ячейкам столбца номер Col N = N + 1 ‘перейти к следующей ячейке ‘При переходе к следующей десятке элементов массива A, расширяем ‘его на 10 элементов, сохраняя предыдущие значения If (N Mod 10) = 0 Then ReDim Preserve a(N + 10) a(N) = Cells(N, Col) ‘ Читаем из очередной ячейки данные ‘Если в A(N) записано значение Empty (Пусто), то выходим из цикла Loop While a(N) <> Empty ‘Последний элемент массива A=Empty. Исключаем его из ‘рассмотрения N = N — 1 If N = 0 Then MsgBox («Столбец пуст»): Exit Sub For i = 1 To N ‘считать данные находящиеся в столбце Col, в массив a a(i) = Cells(i, Col) Next i mn = a(1) For i = 1 To N ‘ ищем миниальное значение If a(i) < nm Then nm = a(i) End If Next i For i = 1 To N ' Ищем в массиве четные числа в 2 раза больше минимального элемента If a(i) / 2 = mn And a(i) Mod 2 = 0 Then Cells(i, Col).Interior.Color = &H1100FF End If Next i End Sub Результат работы программы: 9.7. Написать программу для вычисления числа: Решение: Нетрудно найти закономерность изменения знака очередного слагаемого (обозначим его z), числителя (b) и знаменателя (a). Переменную S введем для хранения искомой суммы. Параметр z для первого слагаемого равен 1, а затем изменяет знак на противоположный на каждом шаге. Sub Вариант09Задача7() Dim a As Double, b As Double, S As Double, i As Integer, z As Integer Dim N As Integer, sl As Double N = 51 z = 1 'В этой переменной будем хранить знак очередного слагаемого a = -1 'В этой переменной будем хранить числитель очередного 'слагаемого b = 0 'В этой переменной будем хранить знаменатель очередного 'слагаемого S = 1 'Здесь накапливаем сумму слагаемых. Пока S = первому 'слагаемому sl = 1 For i = 1 To N 'Цикл по всем слагаемым a = a + 2 'Очередное значение знаменателя b = b + 2 'Очередное значение числителя sl = sl * a / b z = -z S = S + z * (sl) 'Накапливаем сумму i-того слагаемого Next i Debug.Print " Сумма ="; S; "." End Sub Результат работы программы: Сумма = 0,667894495340248 9.8. Вводятся координаты трех точек на плоскости. Написать программу, которая вычисляет площадь треугольника, вершины которого находятся в указанных точках. Решение: Координаты точки состоят из двух чисел, получаем запросом из форм, по два через пробел. Sub Вариант09Задача8() Dim x1 As Integer, x2 As Integer, x3 As Integer, y1 As Integer, y2 As Integer Dim y3 As Integer, S As Double, x() As String, y() As String, z() As String x = Split(InputBox("Введите координаты первой точки через пробел")) y = Split(InputBox("Введите координаты второй точки через пробел")) z = Split(InputBox("Введите координаты третьей точки через пробел")) x1 = Val(x(0)) x2 = Val(y(0)) x3 = Val(z(0)) y1 = Val(x(1)) y2 = Val(y(1)) y3 = Val(z(1)) S = Abs(0.5 * ((x1 - x3) * (y2 - y3) - (x2 - x3) * (y1 - y3))) Debug.Print "Площадь треугольника = "; S End Sub Рис.1.2. Вывод программы Вариант9Задача8() Площадь треугольника = 55 9.9. При помощи датчика случайных чисел получить матрицу A порядка N (N – целое случайное число в диапазоне от 6 до 15). В той же матрице A поменять местами 1-ый столбец со 2-ым, 3-тий с 4-ым и т.д. Вывести матрицу A до и после преобразования. Решение: Sub Вариант09Задача9() Dim a() As Double, temp() As Double, t As Double, N As Integer Randomize Timer N = Rnd * 9 + 6 ReDim a(N, N), temp(1, 1) Sheets("Лист5").Select: Cells.Clear 'Очищаем весь рабочий лист ' Заполняем матрицу и выводим на лист For i = 1 To N For j = 1 To N a(i, j) = Rnd * 10 Cells(i, j) = a(i, j) Next j Next i ' Меняем местами столбцы и выводим на лист For i = 1 To N For j = 1 To N - 1 Step 2 temp(0, 0) = a(i, j) a(i, j) = a(i, j + 1) a(i, j + 1) = temp(0, 0) Cells(i + N + 1, j) = a(i, j) Cells(i + N + 1, j + 1) = a(i, j + 1) Next j Next i End Sub Результат работы программы: 9.10. Получить целочисленную матрицу A порядка N (N – четное случайное число в диапазоне от 8 до 16). Получить матрицу B=A4. Найти ||A|| и ||B||. Вывести обе матрицы на рабочий лист. Решение: У матрицы все элементы ниже главной диагонали равны 0, а элементы главной диагонали равны 2. Необходимо вычислить нормы обеих матриц. Sub Вариант09Задача10() Dim a() As Integer, N As Integer, i As Integer, j As Integer, k As Integer Dim b, c Randomize Timer: N = Int(Rnd * 5) * 2 + 8: ReDim a(N, N) Sheets("Лист13").Select: Range("a1:z56").Clear 'Обходим по всем элементам, которые находятся выше 'главной диагонали For i = 1 To N For j = 1 To N a(i, j) = ((j - i) \ 2) * 2 + 2 'Записываем нули ниже главной диагонали If j < i Then a(i, j) = 0 Next j, i For i = 1 To N 'Выводим полученную матрицу For j = 1 To N Cells(i, j) = a(i, j) Next j, i b = a For i = 2 To 4 c = WorksheetFunction.MMult(b, a) b = c Next i For i = 1 To N 'Выводим полученную матрицу For j = 1 To N Cells(i + N + 1, j) = c(i, j) Next j, i Debug.Print "Норма матрицы А ="; norma(a) Debug.Print "Норма матрицы B ="; norma(c) End Sub 'Функция для вычисления нормы матрицы Function norma(ByVal matr As Variant) As Double Dim i As Long, j As Long Dim Sum As Double, max As Double, f As Boolean If IsArray(matr) Then If LBound(matr) = LBound(matr, 2) And UBound(matr) = UBound(matr, 2) Then For i = LBound(matr) To UBound(matr) Sum = 0 For j = LBound(matr, 2) To UBound(matr, 2) Sum = Sum + Abs(matr(i, j)) Next j If f Then If max < Sum Then max = Sum Else f = True max = Sum End If Next i norma = max End If End If End Function Результат работы программы: Норма матрицы А = 112 Норма матрицы В = 454080 9. 11. Затабулировать функцию Построить график указанной функции и график касательной к ней в точке с абсциссой x0 = 1. Решение: Sub Вариант09Задача11() Dim a As Double, b As Double, x0 As Double, N As Integer a = -1.5: b = 1.5 'Левая и правая границы отрезка x0 = 1# 'Абсцисса точки касания касательной к графику функции N = 20 'Количество подинтервалов для построения графика Sheets("Лист15").Select: Selection.Clear 'Вывод заглавия графиков Cells(1, 1) = "x": Cells(1, 2) = "ln cos(x)": Cells(1, 3) = "Касательная" 'Вызов подпрограммы которая табулирует функцию и строит ее график Call Graphics(a, b, x0, N, 15) End Sub 'Подпрограмма для табуляции функции и построения ее графика 'и графика касательной к ней в точке с абсциссой x0 Sub Graphics(a As Double, b As Double, x0 As Double, N As Integer, St As Integer) Dim row As Integer, h As Double, x As Double, ctr As String h = (b - a) / N 'Длина подинтервала row = 1 'Номер строки, в которую будут выводится координаты точек 'Цикл по точкам, через которые проводится ломаные линии ctr = "Лист" + Trim(Str(St)) For x = a To b + h / 100 Step h row = row + 1 Cells(row, 1) = x 'Абсцисса функций Cells(row, 2) = Функция(x) 'Значение функции Cells(row, 3) = Tang(x, x0) 'Значение касательной Next x 'Построить графики функций Dim Rang As String 'В этой переменной определим область данных для диаграммы Rang = "a1:c" + Trim(Str(N + 2)) Charts.Add 'Добавить диаграмму 'Определить тип диаграммы. Выбрана точечная со значениями, 'соединенными отрезками без маркеров ActiveChart.ChartType = xlXYScatterSmoothNoMarkers 'Откуда брать данные для диаграммы ActiveChart.SetSourceData Source:=Sheets(ctr).Range(Rang), PlotBy:=xlColumns 'Задает область, в которой будет построена диаграмма ActiveChart.Location Where:=xlLocationAsObject, Name:=ctr End Sub 'Заданная функция Function Функция(x As Double) As Double Функция = Log(Cos(x)) End Function 'Функция, определяющая уравнения касательной /1/ Function Tang(x As Double, x0 As Double) As Double Tang = Dif(x0) * (x - x0) + Функция(x0) End Function 'Вычисление производной функции fun11(x) в точке x /1/ Function Dif(x As Double) As Double Dim dx As Double dx = 0.0001 'Шаг приращения 'Центральная конечно-разностная произв Dif = (Функция(x + dx) - Функция(x - dx)) / (2 * dx) End Function Результат работы программы: 9.12. Написать оптимальную (по числу арифметических операций) программу для вычисления приведенной ниже функции: Построить график данной функции на отрезке [-1;1], а также график касательной к ней в точке с абсциссой x0 = 0,2. Решение: Sub Вариант09Задача12() Dim a As Double, b As Double, x0 As Double, N As Integer a = -1: b = 1 'Левая и правая границы отрезка x0 = 0.2 'Абсцисса точки касания касательной к графику функции N = 10 'Количество подинтервалов для построения графика Sheets("Лист16").Select Selection.Clear 'Очистить рабочий лист от данных 'Вывод заглавия графиков Cells(1, 1) = "x": Cells(1, 2) = "функция": Cells(1, 3) = "касательная" 'Вызов подпрограммы, которая табулирует функцию и строит ее 'график Call Graphics2(a, b, x0, N, 16) End Sub 'Подпрограмма для табуляции функции и построения ее графика 'и графика касательной к ней в точке с абсциссой x0 Sub Graphics2(a As Double, b As Double, x0 As Double, N As Integer, St As Integer) Dim row As Integer, h As Double, x As Double, ctr As String h = (b - a) / N 'Длина подинтервала row = 1 'Номер строки, в которую будут выводится координаты точек 'Цикл по точкам, через которые проводится ломаные линии ctr = "Лист" + Trim(Str(St)) For x = a To b + h / 100 Step h row = row + 1 Cells(row, 1) = x 'Абсцисса функций Cells(row, 2) = Функция2(x) 'Значение функции Cells(row, 3) = Tang2(x, x0) 'Значение касательной Next x 'Построить графики функций Dim Rang As String 'В этой переменной определим область данных для диаграммы Rang = "a1:c" + Trim(Str(N + 2)) Charts.Add 'Добавить диаграмму 'Определить тип диаграммы. Выбрана точечная со значениями, 'соединенными отрезками без маркеров ActiveChart.ChartType = xlXYScatterSmoothNoMarkers 'Откуда брать данные для диаграммы ActiveChart.SetSourceData Source:=Sheets(ctr).Range(Rang), PlotBy:=xlColumns 'Задает область, в которой будет построена диаграмма ActiveChart.Location Where:=xlLocationAsObject, Name:=ctr End Sub Function Функция2(x As Double) As Double Dim a As Double, S As Double, i As Integer, sg As Integer, k As Integer sg = -1 a = 1 S = 0 'в этой переменной накапливаем сумму слагаемых. 'Цикл, который выполняется до тех пор, пока |S|>0,0001 While Abs(a) > 0.0001 i = i + 1 If i Mod 2 = 0 Then sg = -sg a = (x ^ i) / Factorial(i + 1) S = S + a ‘Накапливаем его в переменной S Wend Функция2 = S End Function ‘Функция, определяющая уравнения касательной /1/ Function Tang2(x As Double, x0 As Double) As Double Tang2 = Dif2(x0) * (x — x0) + Функция2(x0) End Function ‘Вычисление производной функции fun12(x) в точке x /1/ Function Dif2(x As Double) As Double Dim dx As Double dx = 0.0001 ‘Шаг приращения ‘Центральная конечно-разностная произв Dif2 = (Функция2(x + dx) — Функция2(x — dx)) / (2 * dx) End Function Function Factorial(ByVal N As Integer) As Long If N = 0 Or N = 1 Then Factorial = 1 Else Factorial = N * Factorial(N — 1) End If End Function Результат работы программы: 9.13. Написать программу для вычисления функции: Программа должна автоматически строить график данной функции на произвольном отрезке [a;b] (a и b вводятся с клавиатуры). Решение: Sub Вариант09Задача13() Dim a As Double, b As Double, x0 As Double, N As Integer, row As Integer Dim x() As String x = Split(InputBox(«Введите начало и конец интервала через пробел»)) a = Val(x(0)) b = Val(x(1)) N = 100 ‘Количество подинтервалов для построения графика Sheets(«Лист17»).Select Selection.Clear ‘Очистить рабочий лист от данных ‘Вывод заглавия графиков Cells(1, 1) = «x»: Cells(1, 2) = «Уравнение» ‘Вызов подпрограммы, которая табулирует функцию и строит ее ‘график row = 1 ‘Номер строки в рабочем листе ‘Первый интервал непрерывности функции Call Graphics13(a, b, N, row, 1) End Sub ‘Функция, график которой необходимо построить Function fun13(ByVal x As Double) As Double If Abs(x ^ 2 — 16) < 0.0001 Then x = x + 0.0001 'Точка разрыва fun13 = x / (x ^ 2 - 16) End Function 'Подпрограмма для табуляции функции и построения ее графика Sub Graphics13(a As Double, b As Double, N As Integer, row As Integer, uprPar As Integer) Dim h As Double, x As Double, Rang As String h = (b - a) / N 'Длина подинтервала 'Цикл по точкам, через которые проводится ломаные линии For x = a To b + h / 100 Step h row = row + 1 Cells(row, 1) = x 'Абсцисса функций Cells(row, 2) = fun13(x) 'Значение функции Next x 'Построить графики функций 'В этой переменной определим область данных для диаграммы Rang = "a1:b" + Trim(Str(3 * N + 4)) Charts.Add 'Добавить диаграмму With ActiveChart 'Определить тип диаграммы. Выбрана точечная со значениями, 'соединенными отрезками без маркеров .ChartType = xlXYScatterLinesNoMarkers 'Откуда брать данные для диаграммы .SetSourceData Source:=Sheets("Лист17").Range(Rang) .Location Where:=xlLocationAsNewSheet 'рисовать сетку .Axes(xlCategory).HasMajorGridlines = True 'область рисунка заполнить цветом 2 (белым) .PlotArea.Interior.ColorIndex = 2 .PlotArea.Border.Weight = xlThick 'толщина линий End With End Sub Результат работы программы: 9.14. Затабулировать функцию двух переменных внутри квадрата 0 ≤ x, y ≤ 2 и области существования функции z. Шаги табуляции Δx=Δy=0,2. Решение: Sub Вариант09Задача14() Dim x As Double, y As Double, z As Double, d As Double Dim i As Long, j As Long Sheets("Лист11").Select: Cells.Clear Cells(1, 1) = "x \ y": i = 1 'Закрасить ячейку Range("a1").Interior.Color = RGB(100, 100, 100) For x = 0 To 2.001 Step 0.2 'Вывод значений координат x i = i + 1 Cells(1, i) = Format(x, "#0.00") Cells(1, i).Interior.Color = RGB(0, 255, 255) Next x i = 1 For y = 0 To 2.001 Step 0.2 'Цикл по точкам на оси Oy i = i + 1 Cells(i, 1) = Format(y, "#0.00") 'Вывод значений координат y Cells(i, 1).Interior.Color = RGB(0, 255, 255) j = 1 For x = 0 To 2.001 Step 0.2 'Цикл по точкам на оси Oy j = j + 1 If 4 - x * x - y * y > 0 Then z = Exp(1) ^ Sqr(4 — x * x — y * y) Cells(i, j) = Format(z, «#0.00») ‘ Здесь функция определена выделяем желтым цветом Cells(i, j).Interior.Color = RGB(255, 255, 0) Else Cells(i, j) = «****» ‘Здесь функция не определена выделяем красным ‘цветом Cells(i, j).Interior.Color = RGB(255, 0, 0) End If Next x, y End Sub Результат работы программы: 9.15. В массив A считать 100 действительных чисел, находящихся в первом столбце рабочего листа. Во всех подмассивах, заключенных между двумя числами, целая часть которых начинается цифрой 1, найти среднеарифметическое значение и присвоить это значение всем элементам данного подмассива. Полученный массив записать во второй столбец. Выделить светло-голубым цветом ячейки, соответствующие преобразованным подмассивам. Кроме того, выделить желтым цветом подмассив максимальной длины. Решение: Sub Вариант09Задача15() Dim a() As Double, N As Integer, k As Integer, Color As Integer, i As Integer Dim beg As Double, sredn As Double, size As Integer, нач As Integer, окон As Integer Dim nSize As Double Sheets(«Лист7»).Select N = 100 ReDim a(N) ‘Отвести 4*N байт под массив a Range(«a1:b» + Trim(Str(N + 5))).Clear ‘Очистить область вывода For i = 1 To N a(i) = Rnd * 100 Cells(i, 1) = a(i) Next i size = 0 ‘Ищем первое число For beg = 2 To N — 1 If Left(CStr(a(beg)), 1) = 1 Then Exit For Next beg Dim началоПодмассива As Integer, Сумма As Double, numbS As Integer началоПодмассива = beg + 1: Сумма = 0: Color = 32: numbS = 0 ‘Выделить 31 цветом первое число Cells(beg, 1).Interior.ColorIndex = 31 For i = beg + 1 To N — 1 If Left(CStr(a(i)), 1) = 1 Then ‘i-тый элемент – нужное число Cells(i, 1).Interior.ColorIndex = 31 If numbS > 0 Then sredn = Сумма / numbS Else sredn = 0 nSize = (i — 1) — началоПодмассива If nSize > size Then ‘ проверяем является ли последовательность самой длинной size = nSize нач = началоПодмассива окон = i — 1 End If For k = началоПодмассива To i — 1 ‘ выделяем последовательность цветом Cells(k, 1).Interior.ColorIndex = 33 a(k) = sredn ‘всем элементам подмассива присваиваем среднее значение Next k Сумма = 0 numbS = 0 ‘Количество слагаемых в цепочке началоПодмассива = i + 1 Else ‘i-тый элемент не является нужным числом Сумма = Сумма + a(i) ‘Накопить сумму подцепочки numbS = numbS + 1 ‘Накопить количество элементов подцепочки End If Next i For k = нач To окон ‘Закрасить самый длинный подмассив Cells(k, 1).Interior.ColorIndex = 27 Next k ‘Выводим измененный массив a For i = 1 To N Cells(i, 2) = a(i) Next i End Sub Результат работы программы: 9.16. При помощи датчика случайных чисел заполнить целочисленную квадратную матрицу A порядка N (N ввести с клавиатуры). Столбцы матрицы A, в которых выше побочной диагонали имеются элементы, являющиеся простыми числами, отсортировать по убыванию элементов. Вывести матрицу A до и после сортировки. Все элементы отсортированных столбцов выделить фиолетовым цветом, а ячейки, в которых находятся простые числа, выделить светло-желтым цветом. Решение: Sub Вариант9Задача16() Dim a() As Integer, N As Integer, t As Integer, S As Integer Dim i As Integer, j As Integer, Col As Integer, Numb5 As Integer Sheets(«Лист10»).Select: Cells.Clear ‘очистить содержимое всего листа N = Val(InputBox(«Введите порядок матрицы»)) ReDim a(N, N) ‘Отвести 4*N*N байт памяти под двумерный массив a Randomize Timer ‘Построение ряда случайных чисел For i = 1 To N ‘Заполнение матрицы случайными числами в диапазоне [1;100] For j = 1 To N ‘и записываем их в начало рабочего листа a(i, j) = Rnd * 99 + 1.1 Cells(i, j) = a(i, j) Next j, i S = 0 For Col = 1 To N — 1 ‘Цикл по всем столбцам матрицы For i = 1 To N — Col ‘ Проверяем только элементы выше побочной диагонали If Not Простое(a(i, Col)) Then S = S + 1 ‘ Нашлось простое End If ‘Для удобства контроля такие элементы выделяем желтым цветом Cells(i, Col).Interior.Color = &H22FFFF Next i If S > 0 Then ‘ Если есть прочтое число выше побочной диагонали, то сортируем столбец For i = 1 To N — 1 For j = 1 To N — i If a(j + 1, Col) > a(j, Col) Then t = a(j, Col): a(j, Col) = a(j + 1, Col): a(j + 1, Col) = t End If Next j, i End If ‘Конец сортировки столбца ‘Полученный столбец матрицы a, выводим на N+1 строку ниже For i = 1 To N Cells(i + N + 1, Col) = a(i, Col) ‘ Выделяем отсортированные столбцы и простые числа в них If S > 0 Then Cells(i + N + 1, Col).Interior.Color = &H9932CC If Not Простое(a(i, Col)) Then Cells(i + N + 1, Col).Interior.Color = &H22FFFF End If Next i S = 0 Next Col ‘Заканчиваем цикл по столбцам матрицы a For i = 1 To N ‘ Последний столбец Cells(i + N + 1, N) = a(i, N) Next i End Sub Function Простое(a As Integer) As Boolean For i1 = 2 To Sqr(a) If (a Mod i1) = 0 Then Простое = True: Exit For Next i1 End Function Результат работы программы для N = 8: 9.17. В выделенном фрагменте русскоязычного документа текстового процессора Word, подсчитать количество слов, в которых больше 4 слогов. Решение: Sub Вариант9Задача17() Dim s As String, нужныхСлов As Integer, J As Integer Dim Word As String, endWord As String, I As Integer, количество As Integer endWord = «. ,!?:» ‘Символы которые означают, что слово закончилось ‘ Выделенный фрагмент запоминаем в переменной s s = ActiveDocument.Content + » » нужныхСлов = 0 ‘ Количество слов в которых больше 4 слогов For I = 1 To Len(s) c = Mid(s, I, 1) ‘ запомним в переменной c i-тый символ фрагмента If InStr(endWord, c) > 0 Then ‘ Конец слова количество = 0 For J = 1 To Len(Word) If LCase(Mid(Word, J, 1)) Like «[а,е,и,о,у,ю,э,я]» Then количество = количество + 1 End If Next J If количество > 4 Then нужныхСлов = нужныхСлов + 1 Word = «» ‘Готовимся к следующему слову Else ‘ Не конец слова. Word = Word + c ‘Накапливаем символ в переменной word End If Next I Debug.Print «Количество слов в которых больше 4 слогов = «; нужныхСлов End Sub Результат работы программы Количество слов в которых больше 4 слогов = 3 9.18. В текстовом файле убрать все слова, содержащие буквы ы и я одновременно. Решение: Sub Вариант9Задача18() Dim s As String, s1 As String, c As String * 1, счетчикЫ As Integer, J As Integer Dim lenWord As Integer, endWord As String, Word As String, счетчикЯ As Integer ‘Открыть файл на чтение. Полное имя файла в кавычках Open «text.txt» For Input As #1 endWord = «. ,!?:» ‘ символы которые означают что слово закончилось ‘Посимвольно записать содержимое файла в переменную s типа String s = «» Word = «» Do ‘ Бесконечный цикл счетчикЫ = 0 счетчикЯ = 0 c = Input(1, #1) ‘ Прочитать с файла очередной символ If InStr(endWord, c) > 0 Or EOF(1) Then ‘ Конец слова For J = 1 To Len(Word) If LCase(Mid(Word, J, 1)) = «я» Then счетчикЯ = счетчикЯ + 1 End If If LCase(Mid(Word, J, 1)) = «ы» Then счетчикЫ = счетчикЫ + 1 End If Next J If счетчикЫ = 0 Or счетчикЯ = 0 Then s = s + Word ‘Записываем слово в s End If If EOF(1) Then Exit Do ‘ Выход из цикла s = s + c ‘Если не конец файла в s дописываем символ c Word = «» ‘Готовимся к следующему слову Else ‘ Не конец слова. Word = Word + c ‘Накапливаем символ в переменной word End If Loop Close #1 ‘Закрыть файл ‘Открыть файл на запись. Полное имя файла в кавычках Open «text.txt» For Output As #1 ‘Записать содержимое переменной s в файл Print #1, s Close #1 ‘Закрыть файл End Sub 9.19. Написать логическую функцию, принимающую значения True, если в целом числе, являющимся единственным аргументом этой функции, все цифры четные. Решение: Sub Вариант9Задача19() ‘ Тестируем функцию Debug.Print «Число 2222 «; ВсеЧислаВЧислеЧетные(2222) Debug.Print «Число 2232 «; ВсеЧислаВЧислеЧетные(2232) End Sub Function ВсеЧислаВЧислеЧетные(x As Integer) As Boolean Dim S As String, i As Integer S = S & CStr(x) ‘ Если какая-нибудь чифра нечетная возвращаем False, иначе True For i = 1 To Len(S) If CInt(Mid(S, i, 1)) Mod 2 <> 0 Then ВсеЧислаВЧислеЧетные = False Exit Function End If Next i ВсеЧислаВЧислеЧетные = True End Function Результат работы программы: Число 2222 True Число 2232 False 9.20. Подсчитать сколько точек в пространстве, координаты которых вводятся с первых трех столбцов рабочего листа, находятся вне эллипсоида 4×2 + 9y2 + 16z2 = 125. Для описания координат точек использовать переменную пользовательского типа. Для проверки принадлежности точки указанной области, использовать логическую функцию. Решение: Sub Вариант9Задача20() Dim P As Point3 Dim i As Long, numberPoint As Long, N As Long Sheets(«Лист9»).Select ‘Координаты точек уже должны быть на этом листе numberPoint = 0 ‘Количество точек, находящихся вне элипсоида N = 0 ‘Номер строки с координатами точки While Cells(N + 2, 1) <> Empty ‘Цикл по всем точкам N = N + 1 P.x = Cells(N, 1) P.y = Cells(N, 2) P.z = Cells(N, 3) ‘Считать координаты очередной точки If ТочкаВнеЭлипсоида(P) Then ‘Если точка находится вне элипсоида numberPoint = numberPoint + 1 Cells(N, 4) = «Эта точка находится вне элипсоида» End If Wend MsgBox («Общее количество точек, находящихся вне элипсоида =» + Str(numberPoint)) End Sub Function ТочкаВнеЭлипсоида(P As Point3) As Boolean ‘Логическое условие, принимающее значение Истина, если точка P ‘ находится вне элипсоида ТочкаВнеЭлипсоида = ((4 * P.x * P.x) + (9 * P.y * P.y) + (16 * P.z * P.z)) / 125 > 1 End Function Результат работы программы: 9.21. В первых 10 столбцах рабочего листа находятся сведения о сотрудниках фирмы. Причем в первых трех столбцах рабочего листа записаны: фамилия, имя и отчество. Необходимо написать программу, делающую выборку сотрудников, по введенным с клавиатуры имени сотрудника и первой цифре его номера телефона. Имена полей и их содержимое придумать самостоятельно. Полученную выборку вывести на второй рабочий лист. Решение: Type Sotr ‘Пользовательский тип сотрудник Fam As String Имя As Stringа Отчество As String Таб№ As Long Доход As Double Tel As String Адрес As String ДеньРождения As Date Отдел As String Стаж As Integer Должность As String End Type Sub Вариант09Задача21() Dim massSotr() As Sotr, N As Integer, i As Integer, j As Integer Dim D1 As Double, D2 As Double, NumbV As Integer, NumbKey As Integer D1 = Val(InputBox(«Введите нижнюю границу диапазона дохода»)) D2 = Val(InputBox(«Введите верхнюю границу диапазона дохода»)) NumbKey = Val(InputBox(«Введите номер поля, по которому сортировать выборку «)) Sheets(«Лист19»).Select N = 0 ‘Номер строки в рабочем листе NumbV = 0 ‘Номер элемента в массиве выборки While Cells(N + 3, 1) <> Empty ‘Цикл: пока в первом столбце есть данные ‘Включать ли сотрудника, сведения о котором в строке N+3 в выборку If Cells(N + 3, 7) > D1 And Cells(N + 3, 7) < D2 Then NumbV = NumbV + 1 'Включаем этого сотрудника в выборку ReDim Preserve massSotr(NumbV) 'Увеличить размерность массива 'Прочитать сведения о сотруднике в массив massSotr Call readSotr(massSotr, N + 3, NumbV) End If N = N + 1 'Перейти к следующей строке Wend 'Вызвать подпрограмму сортировки выборки по ключу NumbKey Call СортировкаSotr(massSotr, NumbV, NumbKey) Sheets("Лист21_1").Select 'Перейти на другой рабочий лист MsgBox ("Объем выборки=" + Str(NumbV)) 'Вывести полученную выборку на рабочий лист Call writeSotr(massSotr, NumbV) End Sub 'Подпрограмма, которая считывает со строки номер N сведения о 'сотруднике в элемент номер NumbV массива massSotr Sub readSotr(massSotr() As Sotr, N As Integer, NumbV As Integer) massSotr(NumbV).Fam = Cells(N, 1) massSotr(NumbV).Имя = Cells(N, 2) massSotr(NumbV).Отчество = Cells(N, 3) massSotr(NumbV).Таб№ = Cells(N, 4) massSotr(NumbV).Должность = Cells(N, 5) massSotr(NumbV).Стаж = Cells(N, 6) massSotr(NumbV).Доход = Cells(N, 7) massSotr(NumbV).Адрес = Cells(N, 8) massSotr(NumbV).ДеньРождения = Cells(N, 9) massSotr(NumbV).Tel = Cells(N, 10) End Sub 'Запись всей выборки в рабочий лист Sub writeSotr(massSotr() As Sotr, N As Integer) Dim i As Integer For i = 1 To N Cells(i + 2, 1) = massSotr(i).Fam + " " + Mid(massSotr(i).Имя, 1, 1) + ". " + Mid(massSotr(i).Отчество, 1, 1) + "." Cells(i + 2, 2) = massSotr(i).Таб№ Cells(i + 2, 3) = massSotr(i).Должность Cells(i + 2, 4) = massSotr(i).Стаж Cells(i + 2, 5) = massSotr(i).Доход Cells(i + 2, 6) = massSotr(i).Адрес Cells(i + 2, 7) = massSotr(i).ДеньРождения Cells(i + 2, 8) = massSotr(i).Tel Next i End Sub 'Сортировка массива типа Sotr по заказанным полям методом "пузырька" Sub СортировкаSotr(massSotr() As Sotr, NumbV As Integer, NumbKey As Integer) Dim t As Sotr, i As Long, j As Long, b As Boolean For i = 1 To NumbV - 1 For j = 1 To NumbV - i Select Case NumbKey 'B - логическая переменная, которая принимает значение true, если 'j+1-ую и j-тую строки надо переставлять Case 1 To 3: b = Trim(massSotr(j + 1).Fam) + Trim(massSotr(j + 1).Имя) + Trim(massSotr(j + 1).Отчество) < Trim(massSotr(j).Fam) + Trim(massSotr(j).Имя) + Trim(massSotr(j).Отчество) Case 4: b = massSotr(j + 1).Таб№ < massSotr(j).Таб№ Case 5: b = massSotr(j + 1).Должность < massSotr(j).Должность Case 6: b = massSotr(j + 1).Стаж < massSotr(j).Стаж Case 7: b = massSotr(j + 1).Доход < massSotr(j).Доход Case 8: b = massSotr(j + 1).Адрес < massSotr(j).Адрес Case 9: b = massSotr(j + 1).ДеньРождения < massSotr(j).ДеньРождения Case 10: b = massSotr(j + 1).Tel < massSotr(j).Tel End Select If b Then 'переставить два соседних элемента t = massSotr(j): massSotr(j) = massSotr(j + 1): massSotr(j + 1) = t End If Next j, i End Sub 9.22. При помощи датчика случайных чисел сгенерировать 100 случайных двоичных чисел типа Long и вывести их в столбец рабочего листа. Перевести эти числа в десятичную систему счисления. Выделить цветом те ячейки, где находятся числа, в двоичном представлении которых имеются более двух цепочек "1100". Числа хранятся в дополнительном коде. В соседний столбец вывести числа в двоичном представлении. Решение: Sub Вариант09Задача22() Dim a As Long, N As Long, bin As String, i As Integer, k As Integer Dim Sum As Integer Sheets("Лист18").Select: Cells.Clear 'Отформатировать столбец b, как текстовый Columns("b").NumberFormat = "@" Randomize Timer N = 100 For i = 1 To N 'Цикл по всем элементам 'Получить целое случайное число в диапазоне[-1000000; 1000000] a = Int(Rnd * 2000000) - 1000000 Cells(i, 1) = a 'Вызвать функцию, которая переводит в двоичный дополнительный 'код число a bin = ПереводВ2Long(a) Cells(i, 2) = bin 'Выводим во второй столбец число в двоичном виде If ЧислоУдовлетворяетЛиУсловиюЗадачи(bin) Then 'Закрасить ячейку цветом, смешав 255 единиц красного цвета, Cells(i, 1).Interior.Color = &HFF1199 '17 - зеленого и 153 - голубого End If Next i End Sub Function ЧислоУдовлетворяетЛиУсловиюЗадачи(ByVal bin As String) As Boolean Dim k As Integer, L As Integer ЧислоУдовлетворяетЛиУсловиюЗадачи = True bin = bin + " " 'В строку bin добавляем пробел справа For k = 1 To 34 'Обходим по всем символам строки bin If Mid(bin, k, 1) = "0" Then 'Вошли в цепочку из нулей L = 1 'Число подряд идущих символов "0" 'Идем до конца этой цепочки и подсчитываем, сколько 'в ней символов "0" k = k + 1 While Mid(bin, k, 1) = "0" 'Цикл пока k-тый символ = 0 k = k + 1: L = L + 1 'Переходим к следующему биту и увеличиваем L Wend 'Вышли из цепочки, содержащей символы "0". Проверяем, длина 'цепочки удовлетворяет ли условию задачи. Если "ДА" - выходим из 'функции If L > 7 And (L Mod 4) = 0 Then Exit Function End If Next k ЧислоУдовлетворяетЛиУсловиюЗадачи = False End Function ‘Функция, которая переводит число типа Long в двоичный формат Function ПереводВ2Long(ByVal a As Long) As String Dim b As Long, i As Integer, S As String S = «» ‘Здесь будем накапливать по одному биту двоичный код числа а ‘В числе B — первый бит =1, а остальные (31 бит)равны 0 b = &H80000000 ‘для определения знака числа (первый бит) If (a And b) = 0 Then S = S + «0» Else S = S + «1» b = &H40000000 ‘второй бит =1 остальные 0 For i = 2 To 32 ‘Обходим по всем числовым битам ‘В числе b i-тый бит = 1 остальные = 0 If (a And b) = 0 Then S = S + «0» Else S = S + «1» b = b / 2 ‘Сдвиг 1 на один бит вправо Next i ПереводВ2Long = S End Function 9.23. Вывести все цифры целого числа 9·2n (n — натуральное число от 1 до 10000). Подсчитать сумму цифр этого числа. Построить гистограмму частоты появления цифр в полученном сверхбольшом числе. Решение: Sub Вариант09Задача23() Dim a As String, c As String, i As Integer, Sum As Integer ‘Входные данные a = «12345678910111213141516171819» ‘Подсчет сколько раз встречалась кажддая из десяти цифр Dim Dig(0 To 9) As Integer, minDig As Integer, k As Integer For i = 1 To Len(a) k = Val(Mid(a, i, 1)) ‘Получить i-тую цифру Dig(k) = Dig(k) + 1 ‘Накопить к-тую цифру в массиве Dig Next i For i = 1 To 10 Cells(2, i) = Dig(i — 1) Next i Sheets(«Лист14»).Select Range(«E6»).Select ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select ActiveChart.SetSourceData Source:=Range(«A2:J2») ActiveChart.FullSeriesCollection(1).XValues = «=Лист14!$A$1:$J$1» ActiveChart.ChartTitle.Text = «Гистограмма» ‘Находим сумму цифр Sum = 0 For i = 1 To Len(a) k = Val(Mid(a, i, 1)) ‘Получить i-тую цифру Sum = Sum + k Next i Debug.Print «Сумма цифр числа =»; Sum End Sub Результат работы программы: 9.24. Считать с первого столбца рабочего листа N (N вводится с клавиатуры) вещественных чисел типа Single. Перевести числа в шестнадцатеричный формат и вывести в соседний столбец. Подсчитать сколько раз встречается каждая цифра в шестнадцатеричном формате числа. Результаты вывести в 3-18 столбцы. Решение: Sub Вариант09Задача24() Dim i As Integer, a As Single, BinSingleA As String Sheets(«Лист8»).Select: i = 0 ‘ Отформатировать столбцы a и b как текстовые Columns(«B:C»).NumberFormat = «@» Do ‘Обход по всем элементам последовательности i = i + 1 If Cells(i, 1) = Empty Then Exit Do ‘Если ячейка пустая — выйти из цикла a = Cells(i, 1) ‘ Переписать в переменную а содержимое ячейки ‘ Переводим действительное число типа Single в двоичный формат BinSingleA = ПереводSingleВДвоичныйФормат(a) Cells(i, 5) = ПереводИз2ВSingle(BinSingleA) Cells(i, 2) = BinSingleA ‘Записываем его во второй столбец ‘Вызываем функцию, преобразующею двоичное число согласно ‘условию задачи 24. Записываем его в ту же переменную BinSingleA BinSingleA = Преобразование24(BinSingleA) Cells(i, 3) = BinSingleA Cells(i, 4) = ПереводИз2ВSingle(BinSingleA) Loop End Sub ‘ Перевод Целого положительного числа в двоичный формат Function ПереводВ2PlusInt(ByVal inta As Long) As String Dim S As String S = «» ‘ Здесь накапливаем число в двоичном виде While inta > 0 ‘Цикл пока число ia больше 0 ‘ Дописываем слева в строку S остаток от деления числа на 2 S = Trim(Str((ia Mod 2))) + S inta = inta \ 2 ‘Делим нацело на 2. Остаток от деления ‘отбрасывается Wend ПереводВ2PlusInt = S End Function ‘ Это перевод дробной части d в двоичный код Function ПереводВ2Дробь(d As Single) As String Dim S As String, i As Integer, id As Integer i = 0: S = «,» ‘ В переменной S получаем 24 знака (после первой 1) мантиссы While i < 24 And Len(S) < 100 i = i + 1 ' количество знаков дробной части после первой 1 id = Int(d * 2) ' Получаем очередную цифру 0 или 1 S = S + Trim(Str(id)) 'Записываем ее в строку s If InStr(S, "1") = 0 Then i = 0 'Пока не появится первая цифра 1, i=0 d = d * 2 - id 'Убираем целую часть. Путем вычитания превращаем 'ее в 0 Wend ПереводВ2Дробь = S End Function Function ПереводSingleВДвоичныйФормат(a As Single) As String Dim S As String, BinIntA As String, inta As Long Dim d As Single, mant As String, P As Integer, s1 As String If a < 0 Then S = "1" Else S = "0" 'Знак числа. Первый бит inta = Int(Abs(a)) ' Целая часть аргумента d = Abs(a) - inta ' Дробная часть аргумента 'BinIntA - Двоичный код вещественного числа в виде ' целая часть +","+дробная часть BinIntA = Trim(ПереводВ2PlusInt(inta)) + Trim(ПереводВ2Дробь(d)) P = InStr(BinIntA, ",") - 1 ' Несмещенный порядок числа ' Если p=0, то порядок или = 0, или отрицательный 'Например. ,0001xxx p=2-5=-3 ; ,1xxxxx p=2-2=0 If P = 0 Then P = 2 - InStr(BinIntA, "1") ' Получение мантиссы If P > 0 Then ‘Берем p разрядов целой части и 24-p бита дробной ‘части mant = Left(BinIntA, P) + Right(BinIntA, Len(BinIntA) — P — 1) Else ‘ берем 24 бита дробной части, начиная с бита 2-p mant = Mid(BinIntA, 2 — P, 24) End If s1 = ПереводВ2PlusInt(P + 126) ‘ Смещенный порядок в двоичном виде ‘ Дополняем слева в порядок нули до 8 символов s1 = String(8 — Len(s1), «0») + s1 ‘Теперь в S1 ровно 8 цифр ‘ К знаку s добавляем порядок S1 и 23 символа мантиссы mant. ‘ Со второй по 24. Первый бит мантиссы всегда равен 1, поэтому ‘ он не хранится S = S + s1 + Mid(mant, 2, 23) ‘ Если число равно 0, то по стандарту все биты равны 0 If Abs(a) = 0 Then S = String(32, «0») ПереводSingleВДвоичныйФормат = S End Function ‘Функция, которая переводит из двоичного числа типа Single, ‘хранимого в переменной типа String, в десятичное Function ПереводИз2ВSingle(S As String) As Single Dim a As Double, P As Integer, b As Integer, m As Double Dim i As Integer, d As Double ‘Определение смещенного порядка числа 2-9 биты b = 1: P = 0 For i = 9 To 2 Step -1 ‘Переводим порядок из 2-ой системы ‘в десятичную P = P + Val(Mid(S, i, 1)) * b ‘Накапливаем сумму b = b * 2 ‘ Это вес соответствующего разряда (2i-2) Next i P = P — 126 ‘ Несмещенный порядок m = 0.5 ‘ Здесь накапливаем мантиссу. Это значение первого ‘скрытого бита d = 0.5 ‘ Это вес первого разряда мантиссы (2-1) For i = 10 To 32 ‘ Цикл по всем разрядам мантиссы d = d / 2 ‘ Вес разряда в мантиссе (28-i) m = m + Val(Mid(S, i, 1)) * d Next i a = m * 2 ^ P ‘ Полученное число ‘ Учет знака числа If Mid(S, 1, 1) = «1» Then a = -a ‘ Если все биты числа S были =0, то число =0 If P = -126 And m = 0.5 Then a = 0 ПереводИз2ВSingle = a End Function ‘ Преобразовать двоичное число по следующему правилу: ‘все цифры C в шестнадцатеричном представлении числа типа ‘Single, заменить шестнадцатеричной цифрой 0 ‘S — двоичное представление числа типа Single, согласно формату ‘IEE 754 Function Преобразование24(ByVal S As String) As String Dim i As Integer ‘Обойти по всем шестнадцатеричным цифрам двоичного числа S For i = 1 To 24 Step 4 ‘Если встретилась цифра C, то вместо первых двух единиц, ‘в двоичном коде этой цифры поставить два нуля If Mid(S, i, 4) = «1100» Then Mid(S, i, 2) = «00» Next i Преобразование24 = S End Function Результат работы программы: