Динамическое создание компонентов

Текущая версия на 11:15, 12 ноября 2009

В Гедымине существует возможность динамического создания компонентов в момент выполнения программы. Рассмотрим данную возможность на примере популярной игры Пятнашки. Создадим глобальный макрос Game15. Его задача -- сформировать DFM окна игры (диалоговая форма квадратной формы с расположенной на ней панелью -- игровое поле). Данный DFM записывается в глобальное хранилище, в папку NewForm. После чего можно создавать экземпляр такой формы используя функцию Creator.GetObject:

Option Explicit
Sub Game15
  Dim St, A(0), F, Creator
  Set Creator = new TCreator
  A(0) = "" &_
    "object usrf_game15: TgdcCreateableForm" & vbCrLf &_
    "  BorderStyle = bsDialog" & vbCrLf &_
    "  ClientWidth = 136" & vbCrLf &_
    "  ClientHeight = 136" & vbCrLf &_
    "  Position = poScreenCenter" & vbCrLf &_
    "  object Field: TPanel" & vbCrLf &_
    "    Left = 4" & vbCrLf &_
    "    Top = 4" & vbCrLf &_
    "    Width = 128" & vbCrLf &_
    "    Height = 128" & vbCrLf &_
    "    BevelInner = bvNone" & vbCrLf &_
    "    BevelOuter = bvLowered" & vbCrLf &_
    "  end" & vbCrLf &_
    "end"
  Set St = Creator.GetObject(A, "TStringStream", "")

  GlobalStorage.WriteInteger "NewForm\usrf_game15", "InternalType", 1
  GlobalStorage.WriteString "NewForm\usrf_game15", "Class", "TgdcCreateableForm"
  GlobalStorage.WriteStream "NewForm\usrf_game15", "dfm", St

  Set F = Creator.GetObject(Application, "usrf_game15", "game15")
  F.ShowModal
End Sub

Запустим макрос на выполнение. На экране должна открыться форма с единственной, чистой панелью. Переведем ее в режим дизайнера (Ctrl-Alt-E) и в Инспекторе объектов на вкладке События создадим обработчики для событий OnCreate и OnClose.

[править] OnCreate

 '#include GAME15_ONCLICK
 option explicit
 sub usrf_game15OnCreate(ByVal Sender)
 '*** Данный код необходим для вызова встроенного обработчика ***
 '*** В случае его удаления возможно нарушение работы системы ***
   call   Inherited(Sender, "OnCreate", Array(Sender))
 '*** конец кода поддержки встроенного обработчика            ***

   const CellSize = 32
   const FieldWidth = 4

   dim I, P, C
   set C = Sender.GetComponent("Field")

   for I = 0 to (FieldWidth * FieldWidth - 2)
     set P = Designer.CreateObject(Sender, "TPanel", "P" & I)
     P.Left = (I mod FieldWidth) * CellSize
     P.Top = (I \ FieldWidth) * CellSize
     P.Width = CellSize
     P.Height = CellSize
     P.Caption = I + 1
     P.Parent = C
     SetEventHandler P, "OnClick", "game15_OnClick"
   next

   for I = 1 to 1000
     game15_OnClick Sender.GetComponent("P" & Int((FieldWidth * FieldWidth - 1) * Rnd))
   next

 end sub

[править] OnClose

 option explicit
 sub usrf_game15OnClose(ByVal Sender, ByRef Action)
 '*** Данный код необходим для вызова встроенного обработчика ***
 '*** В случае его удаления возможно нарушение работы системы ***
   Dim ParamArr(1)
   Set   ParamArr(0) = Sender
   ParamArr(1) = Action
   call   Inherited(Sender, "OnClose", ParamArr)
   Action.Value = ParamArr(1)
 '*** конец кода поддержки встроенного обработчика            ***

   Dim F
   Set F = GlobalStorage.OpenFolder("NewForm", False, False)
   if Assigned(F) then
     F.DeleteFolder "usrf_game15"
   end if
   GlobalStorage.CloseFolder F, True

   Action.Value = caFree
 end sub

[править] OnClick

 option explicit
 function game15_CanMove(Parent, X, Y)
   game15_CanMove = False

   if (X >= 0) and (X < Parent.Width) and (Y >= 0) and (Y < Parent.Height) then
     dim I, C
     for I = 0 to Parent.ControlCount - 1
       set C = Parent.Controls(I)
       if (X >= C.Left) and (X < C.Left + C.Width) and (Y >= C.Top) and (Y < C.Top + C.Height) then
         exit function
       end if
     next

     game15_CanMove = True
   end if
 end function

 function game15_OnClick(Sender)
   if game15_CanMove(Sender.Parent, Sender.Left + 32 + 1, Sender.Top) then
     Sender.Left = Sender.Left + 32
   elseif game15_CanMove(Sender.Parent, Sender.Left - 32 + 1, Sender.Top) then
     Sender.Left = Sender.Left - 32
   elseif game15_CanMove(Sender.Parent, Sender.Left, Sender.Top + 32 + 1) then
     Sender.Top = Sender.Top + 32
   elseif game15_CanMove(Sender.Parent, Sender.Left, Sender.Top - 32 + 1) then
     Sender.Top = Sender.Top - 32
   end if

   Dim I
   I = CInt(Sender.Caption) - 1
   if (Sender.Left = (I mod 4) * 32) and (Sender.Top = (I \ 4) * 32) then
     Sender.Color = &HFFFFFF
   else
     Sender.Color = &HA0A0A0
   end if

 end function