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

Версия 20:24, 26 марта 2007

...

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

 '#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

 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

 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