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



Курсовая работа по дисциплине «Информатика»
Вариант №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

Результат работы программы:

Узнать сколько стоит решение этого задания
(ответ в течение 5 мин.)
X