Шаг 201.
VBA в MSExcel. Практические приемы программирования на VBA. Тема: построение поверхности. Практика

    На этом шаге мы рассмотрим основные моменты создания указанного приложения.

    В данном приложении строится поверхность по введенным в диалоговое окно построение поверхности (рисунок 1) начальным, конечным значениям аргументов и их шагах изменения.


Рис.1. Диалоговое окно Построение поверхности

    Уравнение поверхности также вводится в программу из диалогового окна. Уравнение должно быть составлено в соответствии с правилами, по которым строятся функции рабочего листа, но в качестве аргументов в нем следует использовать х и у вместо ссылок на ячейки. Программа сама переведет эти аргументы в ссылки на ячейки. После табуляции введенной функции программой и построения поверхности на рабочем листе (рисунок 2), эта поверхность также отображается в объекте управления Image, расположенном в диалоговом окне построение поверхности (рисунок 3).


Рис.2. Результат построения поверхности на рабочем листе


Рис.3. Диалоговое окно Построение поверхности с рисунком построенной поверхности

    Управляя полосами прокрутки можно изменить ориентацию поверхности на рабочем листе.

    Обсудим, как приведенная ниже программа решает описанную задачу и что происходит в ней.

UserForm_Initialize
  1. Активизирует диалоговое окно.
  2. Назначает клавише Esc функцию кнопки Отмена, а клавише Enter - Вычислить.
  3. Устанавливает максимальные и минимальные допустимые значения для полос прокрутки, a также их первоначальные значения. Устанавливает, чтобы отображаемая картинка поверхности в диалоговом окне помещалась целиком и пропорционально в пределах элемента управления Image, а также чтобы левый верхний угол рисунка совпадал с левым верхним углом элемента управления Image.

Нажатие кнопки Вычислить запускает на выполнение процедуру CommandButton1_Click
  1. Проверяет, являются ли вводимые данные числами. В случае ошибки отображается cooветствующее сообщение.
  2. Проверяет согласованность вводимых данных. В случае ошибки отображается соответствующее сообщение (рисунок 4).


    Рис.4. Пример сообщения о несогласованности данных

  3. Преобразует формулу, введенную в поле Уравнение поверхности, в формулу рабочего листа.
  4. Проверяет корректность введенной формулы. В случае ошибки отображается соответствующее сообщение (рисунок 5).


    Рис.5. Сообщение о некорректном вводе формулы

  5. Используя метод DataSeries, начиная с ячейки А2 строит вниз по столбцу арифметическую прогрессию, являющуюся результатом табуляции аргумента х уравнения поверхности с указанными шагами.
  6. Используя метод DataSeries, начиная с ячейки В1 строит вправо по строке арифметическую прогрессию, являющуюся результатом табуляции аргумента у уравнения поверхности с указанными шагами.
  7. Заносит в ячейку В2 уравнение поверхности, введенное пользователем в диалоговом окне. Для корректности последующего табулирования значений функций важно в уравнении указать абсолютные ссылки на столбец A и строку B. Это обеспечивается вводом в уравнении поверхности вместо аргумента х ссылки $А2, а вместо аргумента y - ссылки B$1.
  8. Для табуляции функции протаскивается маркер заполнения ячейки В2, используя метод AutoFill и формулу поверхности, позволяющих распространить табуляцию на весь диапазон, где табулируется функция.
  9. Строит поверхности при помощи метода ChartWizard.
  10. Изменяет ориентацию надписи оси Z.
  11. Сохраняет построенную поверхность в файле График.gif.
  12. Отображает рисунок из файла График.gif в элементе управления Image1.

Нажатие кнопки Отмена запускает на выполнение процедуру CommandButton2_Click
Закрывает диалоговое окно.

ScrollBar1_Change
Перемещение ползунка горизонтальной полоски прокрутки вызывает вращение вокруг оси Z диаграммы за счет изменения величины свойства Rotation.

ScrollBar2_Change
Перемещение ползунка вертикальной полоски прокрутки вызывает изменение угла, под которым смотрят на диаграмму, за счет изменения величины свойства Elevation.

ВращениеГрафика
Программирует вращение поверхности за счет изменения свойств Rotation и Elevation.

    Приведем полный текст приложения. 

' Описание переменных уровня модуля
Dim УголЗрения As Integer
Dim ВокругОсиZ As Integer
Dim УголЗренияСоСчётчика As Integer
' УголЗренияСоСчетчика - величина, снимаемая с полосы прокрутки
' и определяющая угол зрения под которым смотрят на поверхность
' УголЗрения - угол зрения, под которым смотрят на поверхность,
' он равен УголЗренияСоСчетчика - 90 и лежит в
' диапазоне от -90 до 90
' ВокругОсиZ - угол поворота вокруг оси z, лежит в
' диапазоне от 0 до 360

Private Sub CommandButton1_Click()
 ' Процедура табуляции функции
 ' и построения поверхности

  Dim х_нз As Double
  Dim х_пз As Double
  Dim х_шаг As Double
  Dim у_нз As Double
  Dim у_пз As Double
  Dim у_шаг As Double
  Dim УрПоверхности As String
  ' Переменная х:
  ' х_нз - начальное значение
  ' х_пз - предельное значение
  ' х_шаг - шаг изменения
  ' Переменная у:
  ' у_нз - начальное значение
  ' у_пз - предельное значение
  ' у_шаг - шаг изменения
  ' УрПоверхности - уравнение поверхности

  Dim nx As Integer
  Dim ny As Integer
  ' nx - число протабулированных значений аргумента х
  ' ny - число протабулированных значений аргумента у

  Dim n As Integer
  Dim i As Integer
  ' n ,i - вспомогательные целые переменные

  Dim ПоляВвода(1 To 6) As Object
  ' Массив полей ввода
  Set ПоляВвода(1) = TextBox1
  Set ПоляВвода(2) = TextBox2
  Set ПоляВвода(3) = TextBox3
  Set ПоляВвода(4) = TextBox4
  Set ПоляВвода(5) = TextBox5
  Set ПоляВвода(6) = TextBox6

  ' Проверка корректности ввода данных
  For i = 1 To 6
   If IsNumeric(ПоляВвода(i).Text) = False Then
   Select Case i
   Case 1
      MsgBox "Ошибка в начальном значении х", vbInformation, _
          "Поверхность"
      TextBox1.SetFocus
      Exit Sub
   Case 2
      MsgBox "Ошибка в начальном значении y", vbInformation, _
          "Поверхность"
      TextBox2.SetFocus
      Exit Sub
   Case 3
      MsgBox "Ошибка в шаге х", vbInformation, _
          "Поверхность"
      TextBox3.SetFocus
      Exit Sub
   Case 4
      MsgBox "Ошибка в шаге у", vbInformation, _
          "Поверхность"
      TextBox4.SetFocus
      Exit Sub
   Case 5
      MsgBox "Ошибка в конечном значении х", vbInformation, _
          "Поверхность"
      TextBox5.SetFocus
      Exit Sub
   Case 6
      MsgBox "Ошибка в конечном значении х", vbInformation, _
          "Поверхность"
      TextBox6.SetFocus
      Exit Sub
   End Select
   End If
  Next i

  ' Считывание с диалогового окна
  ' значений переменных
  х_нз = CDbl(TextBox1.Text)
  у_нз = CDbl(TextBox2.Text)
  х_шаг = CDbl(TextBox3.Text)
  у_шаг = CDbl(TextBox4.Text)
  х_пз = CDbl(TextBox5.Text)
  у_пз = CDbl(TextBox6.Text)
  УрПоверхности = Trim(TextBox7.Text)

  ' Проверка согласованности введенных данных
  If х_нз >= х_пз Then
   MsgBox "Начальная значение х слишком большое", vbInformation, "Поверхность"
   TextBox1.SetFocus
   Exit Sub
  End If
  If х_нз + х_шаг >= х_пз Then
   MsgBox "Шаг великоват", vbInformation, "Поверхность"
   TextBox3.SetFocus
   Exit Sub
  End If
  If у_нз >= у_пз Then
   MsgBox "Шаг великоват", vbInformation, "Поверхность"
   TextBox2.SetFocus
   Exit Sub
  End If
  If у_нз + у_шаг >= у_пз Then
   MsgBox "Шаг великоват", vbInformation, "Поверхность"
   TextBox4.SetFocus
   Exit Sub
  End If

  ' Переход на отладчик ошибок в случае их возникновения
  On Error GoTo Сообщение

  ' Замена в введенной формуле аргумента х на ссылку $А2,
  ' а аргумента у на ссылку В$1
  i = 1
  Do
    ' Замена в введенной формуле аргумента х на ссылку $А2
    If Mid(УрПоверхности, i, 1) = "x" Or Mid(УрПоверхности, i, 1) = "X" Then
      n = Len(УрПоверхности)
      If (1 < i) And (i < n) Then
           УрПоверхности = Left(УрПоверхности, i - 1) & "$A2" & _
                                              Right(УрПоверхности, n - i)
      End If
      If i = 1 Then УрПоверхности = "$A2" & Right(УрПоверхности, n - 1)
      If i = n Then УрПоверхности = Left(УрПоверхности, n - 1) & "$A2"
    End If

    ' Замена в введенной формуле аргумента у на ссылку В$1
    If Mid(УрПоверхности, i, 1) = "y" Or Mid(УрПоверхности, i, 1) = "Y" Then
      n = Len(УрПоверхности)
      If (1 < i) And (i < n) Then
        УрПоверхности = Left(УрПоверхности, i - 1) & "B$1" & _
                                             Right(УрПоверхности, n - i)
      End If
      If i = 1 Then УрПоверхности = "B$1" & Right(УрПоверхности, n - 1)
      If i = n Then УрПоверхности = Left(УрПоверхности, n - 1) & "B$1"
    End If
    i = i + 1
  Loop While i <= Len(УрПоверхности)

  ' Очистка на активном листе ранее введенных данных
  ActiveSheet.Cells.Select
  Selection.Clear

  ' Заполнение диапазонов значениями аргументов
  With ActiveSheet
    ' Ввод в ячейку А2 начального значения
    .Range("A2").Value = х_нз
    ' Создание арифметической прогрессии по столбцу
    ' с указанными шагом и начальным значением
    .Range("A2").DataSeries rowcol:=xlColumns, _
        Type:=xlLinear, step:=х_шаг, stop:=х_пз, Trend:=False
    ' Ввод в ячейку B1 начального значения
    .Range("B1").Value = у_нз
    ' Создание арифметической прогрессии вдоль строки
    ' с указанными шагом и начальным значением
    .Range("B1").DataSeries rowcol:=xlRows, _
        Type:=xlLinear, step:=у_шаг, stop:=у_пз, Trend:=False
  End With

  ' Заполнение диапазона значениями функции
  With ActiveSheet
   ' Определение числа строк в диапазоне заполнения
   nx = .Range("A1").CurrentRegion.Rows.Count
   ' Определение числа столбцов в диапазоне заполнения
   ny = .Range("A1").CurrentRegion.Columns.Count
   ' Ввод уравнения поверхности в ячейку В2
   .Range("b2").Formula = УрПоверхности
   If IsError(Evaluate(УрПоверхности)) = True Then
      MsgBox "Ошибка в формуле", vbExclamation, "Поверхность"
      Exit Sub
   End If

   ' Заполнение диапазона Range(Cells(2, 2), Cells(2, ny))
   ' начиная с ячейки В2, что эквивалентно протаскиванию маркера
   ' заполнения ячейки В2 на диапазон
   .Range("B2").AutoFill _
        Destination:=Range(Cells(2, 2), Cells(2, ny)), _
         Type:=xlFillDefault

   ' Заполнение диапазона Range(Cells(2, 2), Cells(nx, ny)),
   ' начиная с диапазона Range(Cells(2, 2), Cells(2, ny)),
   ' что эквивалентно протаскиванию маркера
   ' заполнения диапазона Range(Cells(2, 2), Cells(2, ny))
   ' на диапазон Range(Cells(2, 2), Cells(nx, ny))
   .Range(Cells(2, 2), Cells(2, ny)).AutoFill _
        Destination:=Range(Cells(2, 2), Cells(nx, ny)), _
         Type:=xlFillDefault
  End With

  ' Удаление с рабочего листа всех ранее построенных диаграмм
  ActiveSheet.ChartObjects.Delete
  ' Выбор диапазона, по которому строится поверхность
  ActiveSheet.Range(Cells(2, 2), Cells(nx, ny)).Select
  ' Задание и выбор области на рабочем листе, где
  ' будет построена поверхность
  ActiveSheet.ChartObjects.Add(29.25, 19.5, 270.75, 187.5).Select
  Application.CutCopyMode = False

  ' Построение поверхности
  ActiveChart.ChartWizard Source:=Range(Cells(1, 1), Cells(nx, ny)), _
         gallery:=xl3DSurface, Format:=1, _
         PlotBy:=xlColumns, categorylabels:=1, _
         serieslabels:=1, HasLegend:=False, _
         Title:="Поверхность", categorytitle:="x", _
         valuetitle:="z", extratitle:="y"
  ActiveSheet.ChartObjects(1).Activate
   ActiveChart.Axes(xlValue).AxisTitle.Select
  With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = xlVertical
  End With
     
  ВращениеГрафика 20, 15
 
  ' Запись диаграммы в файл и
  ' загрузка картинки в Imagel
   ActiveChart.Export Filename:="График.gif", filtername:="gif"
   UserForm1.Image1.Picture = LoadPicture("График.gif")
   ActiveSheet.Range("A1").Select
  Exit Sub

Сообщение:
     MsgBox "Ошибка:" & Err.Description, vbExclamation, "Поверхность"
     TextBox7.SetFocus
  Exit Sub
End Sub

Private Sub CommandButton2_Click()
  ' Процедура закрытия диалогового окна
  UserForm1.Hide
End Sub

Private Sub ScrollBar1_Change()
  ' Процедура вращения вокруг оси z

  ' Считывание данных с полос прокрутки
  ВокругОсиZ = CInt(ScrollBar2.Value)
  УголЗренияСоСчётчика = CInt(ScrollBar1.Value)
  УголЗрения = УголЗренияСоСчётчика - 90

  ' Вращение поверхности
  ВращениеГрафика ВокругОсиZ, УголЗрения
End Sub

Private Sub ScrollBar2_Change()
  ' Процедура изменения угла, под которым
  ' смотрят на диаграмму

  ' Считывание данных с полос прокрутки
  ВокругОсиZ = CInt(ScrollBar2.Value)
  УголЗренияСоСчётчика = CInt(ScrollBar1.Value)
  УголЗрения = УголЗренияСоСчётчика - 90

  ' Вращение поверхности
  ВращениеГрафика ВокругОсиZ, УголЗрения
End Sub

Sub ВращениеГрафика(ByVal ВокругОсиZ, ByVal УголЗрения As Integer)
  ' Процедура вращения поверхности

  If ActiveSheet.ChartObjects.Count >= 1 Then
   ActiveSheet.ChartObjects(1).Activate
   With ActiveChart
      ' Угол, под которым смотрят на диаграмму,
      ' допустимые значения от -90 до 90,
      ' по умолчанию 15
      .Elevation = УголЗрения
      ' Вращение вокруг оси z, допустимые значения от 0 до 360,
      ' по умолчанию 20
      .Rotation = ВокругОсиZ
   End With
  End If
End Sub

Private Sub UserForm_Initialize()
  ' Процедура инициализации диалогового окна
  CommandButton1.Default = True
  CommandButton2.Cancel = True
  ScrollBar1.ControlTipText = "Поворот вокруг оси Z"
  ScrollBar2.ControlTipText = "Изменение угла зрения"

  УголЗрения = 15
  ВокругОсиZ = 20

  ' Рисунок масштабируется с учетом относительных размеров так,
  ' чтобы он помещался в объекте Imagel
  With Image1
  .PictureAlignment = fmPictureAlignmentTopLeft
  .PictureSizeMode = fmPictureSizeModeStretch
  End With

  ' Установка максимальных и минимальных допустимых значений
  ' для полос прокрутки, а
  ' также их первоначальных значений
  With ScrollBar1
   .Min = 0
   .Max = 180
   .Value = 105
  End With
  With ScrollBar2
   .Min = 0
   .Max = 360
   .Value = 20
  End With
End Sub
Текст этого примера можно взять здесь.

    На следующем шаге мы продолжим разработку приложений.




Предыдущий шаг Содержание Следующий шаг