TinyDesigner - small Form Designer

eodor · Post by **eodor** » Nov 24, 2013 13:53

Try and enjoy.
Designer.bi

/' 
  Simple Designer. Educational purposes.
  (c)2013 Nastase Eodor
  nastasa.eodor@gmail.com
  http://rqwork.xhost.ro
'/

#include once "windows.bi"

#define instance GetModuleHandle(0)

type PDesigner as TDesigner ptr

type TWindowList
    Count  as integer
    Child  as HWND ptr
end type

type TDesigner extends Object
    private:
      declare static function HookChildProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
      declare static function HookDialogProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
      declare static function DotWndProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
      FPopupMenu     as HMENU
      FActive        as integer 
      FStepX         as integer
      FStepY         as integer
      FShowGrid      as Boolean
      FChilds        as TWindowList
      FDialog        as HWND
      FClass         as string
      FGridBrush     as HBRUSH
      FDotColor      as integer
      FDotBrush      as HBRUSH
      FSnapToGrid    as Boolean
      FDown          as Boolean
      FCanInsert     as Boolean
      FCanMove       as Boolean
      FCanSize       as Boolean
      FBeginX        as integer
      FBeginY        as integer
      FNewX          as integer
      FNewY          as integer
      FEndX          as integer
      FEndY          as integer
      FLeft          as integer
      FTop           as integer
      FWidth         as integer
      FHeight        as integer
      FSelControl    as HWND
      FOverControl   as HWND
      FDotIndex      as integer
      FDots(7)       as HWND
      FStyleEx       as integer
      FStyle         as integer
      FID            as integer
    protected:
      declare static function EnumChildsProc(hDlg as HWND, lParam as LPARAM) as Boolean
      declare        function IsDot(hDlg as HWND) as integer
      declare        sub RegisterDotClass
      declare        sub CreateDots(Parent as HWND)
      declare        sub DestroyDots
      declare        sub HideDots
      declare        sub MoveDots(Control as HWND)
      declare        sub CreateControl(AClassName as string, AName as string, AText as string, AParent as HWND, x as integer,y as integer, cx as integer, cy as integer)
      declare        function ControlAt(Parent as HWND,X as integer,Y as integer) as HWND
      declare        sub DrawGrid(DC as HDC, R as RECT)
      declare        sub Hook
      declare        sub UnHook
      declare        sub GetChilds(Parent as HWND = 0)
      declare        sub UpdateGrid
      declare        sub PaintGrid
      declare        sub ClipCursor(hDlg as HWND)
      declare        sub DrawBox(R as RECT)
      declare        sub DrawBoxs(R() as RECT)
      declare        sub DeleteControl(hDlg as HWND)
      declare        sub Clear 
      declare        function GetClassAcceptControls(AClassName as string) as Boolean
      declare        sub MouseDown(X as integer, Y as Integer, Shift as integer)
      declare        sub MouseUp(X as integer, Y as Integer, Shift as integer)
      declare        sub MouseMove(X as integer, Y as Integer, Shift as integer)
      declare        sub KeyDown(Key as word, Shift as integer)
      crArrow        as HCURSOR = LoadCursor(0, IDC_ARROW)
      crHandPoint    as HCURSOR = LoadCursor(0, IDC_HAND)
      crCross        as HCURSOR = LoadCursor(0, IDC_CROSS)
      crSize         as HCURSOR = LoadCursor(0, IDC_SIZEALL) 
      crSizeNESW     as HCURSOR = LoadCursor(0, IDC_SIZENESW)
      crSizeNS       as HCURSOR = LoadCursor(0, IDC_SIZENS)
      crSizeNWSE     as HCURSOR = LoadCursor(0, IDC_SIZENWSE)
      crSizeWE       as HCURSOR = LoadCursor(0, IDC_SIZEWE)
    public:
      OnChangeSelection  as sub(ByRef Sender as TDesigner, Control as HWND)
      OnDeleteControl    as sub(ByRef Sender as TDesigner, Control as HWND)
      OnModified         as sub(ByRef Sender as TDesigner, Control as HWND)
      OnInsertControl    as sub(ByRef Sender as TDesigner, ByRef ClassName as string, Control as HWND)
      OnInsertingControl as sub(ByRef Sender as TDesigner, ByRef AClass as string, ByRef AStyleEx as integer, AStyle as integer, ByRef AID as integer) 
      OnMouseMove        as sub(ByRef Sender as TDesigner, X as integer, Y as integer, ByRef Over as HWND)
      declare            function ClassExists() as Boolean
      declare static     function GetClassName(hDlg as HWND) as string
      declare            sub HookControl(Control as HWND)
      declare            sub UnHookControl(Control as HWND)
      declare property Dialog as HWND
      declare property Dialog(value as HWND)
      declare property Active as Boolean
      declare property Active(value as Boolean)
      declare property ChildCount as integer
      declare property ChildCount(value as integer)
      declare property Child(index as integer) as HWND
      declare property Child(index as integer,value as HWND)
      declare property StepX as integer
      declare property StepX(value as integer)
      declare property StepY as integer
      declare property StepY(value as integer)
      declare property DotColor as integer
      declare property DotColor(value as integer)
      declare property SnapToGrid as Boolean
      declare property SnapToGrid(value as Boolean)
      declare property ShowGrid as Boolean
      declare property ShowGrid(value as Boolean)
      declare property ClassName as string
      declare property ClassName(value as string)
      declare operator cast as any ptr
      declare constructor(hDlg as HWND)
      declare destructor
end type

function TDesigner.EnumChildsProc(hDlg as HWND, lParam as LPARAM) as Boolean
    if lParam then
        with *cast(TWindowList ptr, lParam)
            .Count = .Count + 1
            .Child = reallocate(.Child, .Count * sizeof(HWND))
            .Child[.Count-1] = hDlg
        end with 
    end if    
    return true
end function

sub TDesigner.GetChilds(Parent as HWND = 0)
    FChilds.Count = 0
    FChilds.Child = callocate(0)
    EnumChildWindows(iif(Parent, Parent, FDialog), cast(WNDENUMPROC, @EnumChildsProc), cint(@FChilds)) 
end sub

sub TDesigner.ClipCursor(hDlg as HWND)
     dim as RECT R
     if IsWindow(hDlg) then
         GetClientRect(hDlg, @R)
         MapWindowPoints(hDlg, 0,cast(POINT ptr, @R), 2)
         .ClipCursor(@R)
     else
         .ClipCursor(0)
     end if
end sub

sub TDesigner.DrawBox(R as RECT)
     dim as HDC Dc = GetDCEx(FDialog, 0, DCX_PARENTCLIP or DCX_CACHE or DCX_CLIPSIBLINGS)
     dim as HBRUSH Brush = GetStockObject(NULL_BRUSH)
     dim as HBRUSH PrevBrush = SelectObject(Dc, Brush)
     SetROP2(Dc, R2_NOT)
     Rectangle(Dc, R.Left, R.Top, R.Right, R.Bottom)
     SelectObject(Dc, PrevBrush)
     ReleaseDc(FDialog, Dc)
end sub

sub TDesigner.DrawBoxs(R() as RECT) 
    '''for future implementation of multiselect suport
    for i as integer = 0 to ubound(R)
        DrawBox(R(i))
    next    
end sub

function TDesigner.GetClassAcceptControls(AClassName as string) as Boolean
    '''for future implementation of classbag struct
    return false
end function

sub TDesigner.Clear
    GetChilds
    for i as integer = FChilds.Count -1 to 0 step -1
        DestroyWindow(FChilds.Child[i])
    next
    HideDots
end sub

function TDesigner.ClassExists() as Boolean
    dim as WNDCLASSEX wcls
    wcls.cbSize = sizeof(wcls)
    return (FClass <> "") and (GetClassInfoEx(0, FClass, @wcls) or GetClassInfoEx(instance, FClass, @wcls))
end function

function TDesigner.GetClassName(hDlg as HWND) as string
    dim as string s = space(255)
    dim as integer L = .GetClassName(hDlg, s, Len(s))
    return trim(Left(s, L))
end function    

function TDesigner.ControlAt(Parent as HWND,X as integer,Y as integer) as HWND
    dim as RECT R
    GetChilds(Parent)
    for i as integer = 0 to FChilds.Count -1
        if IsWindowVisible(FChilds.Child[i]) then
           GetWindowRect(FChilds.Child[i], @R)
           MapWindowPoints(0, Parent, cast(POINT ptr, @R) ,2)
           if (X > R.Left and X < R.Right) and (Y > R.Top and Y < R.Bottom) then
              return FChilds.Child[i]
           end If
        end if
    next i
    return Parent
end function

sub TDesigner.CreateDots(Parent as HWND)
    for i as integer = 0 to 7
        FDots(i) = CreateWindowEx(WS_EX_TOPMOST, "DOT", "",WS_POPUP or WS_CHILD or WS_CLIPSIBLINGS or WS_CLIPCHILDREN, 0, 0, 6, 6, Parent, 0, instance, 0)
        if IsWindow(FDots(i)) then  
            SetWindowLong(FDots(i), 0, cint(@this))
        end if    
    next i
end sub

sub TDesigner.DestroyDots
    for i as integer = 7 to 0 step -1
        DestroyWindow(FDots(i))
    next i
end sub

sub TDesigner.HideDots
    for i as integer = 0 to 7
        ShowWindow(FDots(i), SW_HIDE)
    next i
end sub

sub TDesigner.MoveDots(Control as HWND)
    dim as RECT R
    dim as POINT P
    dim as integer iWidth, iHeight
    if IsWindow(Control) then
       if Control <> FDialog then
           GetWindowRect(Control, @R)
           iWidth  = R.Right  - R.Left
           iHeight = R.Bottom - R.Top
           P.x     = R.Left
           P.y     = R.Top
           ScreenToClient(GetParent(Control), @P)
           for i as integer = 0 to 7
               SetParent(FDots(i), GetParent(Control))
               SetProp(FDots(i),"@@@Control", Control)
           next i
           SetWindowPos(FDots(0), HWND_TOP, P.X-3, P.Y-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(1), HWND_TOP, P.X+iWidth/2-3, P.Y-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(2), HWND_TOP, P.X+iWidth-3, P.Y-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(3), HWND_TOP, P.X+iWidth-3, P.Y + iHeight/2-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(4), HWND_TOP, P.X+iWidth-3, P.Y + iHeight-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(5), HWND_TOP, P.X+iWidth/2-3, P.Y + iHeight-3,0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(6), HWND_TOP, P.X-3, P.Y + iHeight-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
           SetWindowPos(FDots(7), HWND_TOP, P.X-3, P.Y + iHeight/2-3, 0, 0, SWP_NOSIZE OR SWP_SHOWWINDOW)
       else
          HideDots
       end If
    else
       HideDots
    end if
end sub

function TDesigner.IsDot(hDlg as HWND) as integer
     dim as string s
     s = GetClassName(hDlg)
     if UCase(s) = "DOT" then
        for i as integer = 0 to 7
           if FDots(i) = hDlg then return i
        next i
    end If
    return -1
end function

sub TDesigner.MouseDown(X as integer, Y as Integer, Shift as integer)
    dim as POINT P
    dim as RECT R
    FDown   = true
    FBeginX = iif(FSnapToGrid,(X\FStepX)*FStepX,X)
    FBeginy = iif(FSnapToGrid,(Y\FStepY)*FStepY,y)
    FEndX   = FBeginX
    FEndY   = FBeginY
    FNewX   = FBeginX
    FNewY   = FBeginY
    HideDots
    ClipCursor(FDialog)
    FSelControl = ControlAt(FDialog, X, Y)
    FDotIndex   = IsDot(FOverControl)
    if FDotIndex <> -1 then
        FCanInsert  = false
        FCanMove    = false
        FCanSize    = true
        if not IsWindow(FSelControl) then 
            FSelControl = GetProp(FDots(FDotIndex),"@@@Control")
        end if    
        BringWindowToTop(FSelControl)
        GetWindowRect(FSelControl, @R)
        P.X     = R.Left
        P.Y     = R.Top
        FWidth  = R.Right - R.Left
        FHeight = R.Bottom - R.Top
        ScreenToClient(GetParent(FSelControl), @P)  
        FLeft   = P.X
        FTop    = P.Y 
        select case FDotIndex
        case 0: SetCursor(crSizeNWSE)
        case 1: SetCursor(crSizeNS)
        case 2: SetCursor(crSizeNESW)
        case 3: SetCursor(crSizeWE)
        case 4: SetCursor(crSizeNWSE)
        case 5: SetCursor(crSizeNS)
        case 6: SetCursor(crSizeNESW)
        case 7: SetCursor(crSizeWE)
        end select
        SetCapture(FDialog)
   else
        if FSelControl <> FDialog then
           BringWindowToTop(FSelControl)
           if ClassExists then
               FCanInsert = true
               FCanMove   = false
               FCanSize   = false
               SetCursor(crCross)
           else
               FCanInsert = false
               FCanMove   = true
               FCanSize   = false
               SetCursor(crSize) :SetCapture(FDialog)
               if OnChangeSelection then OnChangeSelection(this, FSelControl)
               GetWindowRect(FSelControl, @R)
               P.X     = R.Left
               P.Y     = R.Top
               FWidth  = R.Right - R.Left
               FHeight = R.Bottom - R.Top
               ScreenToClient(GetParent(FSelControl), @P)
               FLeft   = P.X
               FTop    = P.Y
           end if
        else
           HideDots
           FCanInsert = iif(ClassExists, true, false)
           FCanMove   = 0
           FCanSize   = 0
           if FCanInsert then
               SetCursor(crCross)
           else
              if OnChangeSelection then OnChangeSelection(this, FSelControl)
           end if
       end if
    end if    
end sub

sub TDesigner.MouseMove(X as integer, Y as Integer, Shift as integer)
    dim as POINT P
    FNewX = iif(FSnapToGrid,(X\FStepX)*FStepX,X)
    FNewY = iif(FSnapToGrid,(Y\FStepY)*FStepY,Y)
    if FDown then
       if FCanInsert then
           SetCursor(crCross)
           DrawBox(type<RECT>(FBeginX, FBeginY, FNewX, FNewY))
           DrawBox(type<RECT>(FBeginX, FBeginY, FEndX, FEndY))
       end if
       if FCanSize then
          select case FDotIndex
          case 0: MoveWindow(FSelControl, FLeft + (FNewX - FBeginX), FTop + (FNewY - FBeginY), FWidth - (FNewX - FBeginX), FHeight - (FNewY - FBeginY), true)
          case 1: MoveWindow(FSelControl, FLeft, FTop + (FNewY - FBeginY),FWidth ,FHeight - (FNewY - FBeginY), true)
          case 2: MoveWindow(FSelControl, FLeft, FTop + (FNewY - FBeginY),FWidth + (FNewX - FBeginX) , FHeight - (FNewY - FBeginY), true)
          case 3: MoveWindow(FSelControl, FLeft, FTop, FWidth + (FNewX - FBeginX), FHeight, true)
          case 4: MoveWindow(FSelControl, FLeft, FTop, FWidth + (FNewX - FBeginX), FHeight + (FNewY - FBeginY), true)
          case 5: MoveWindow(FSelControl, FLeft, FTop, FWidth ,FHeight + (FNewY - FBeginY), true)
          case 6: MoveWindow(FSelControl, FLeft + (FNewX - FBeginX), FTop, FWidth - (FNewX - FBeginX), FHeight + (FNewY - FBeginY), true)
          case 7: MoveWindow(FSelControl, FLeft - (FBeginX - FNewX), FTop, FWidth + (FBeginX - FNewX), FHeight, true)
          end Select
       end If
       if FCanMove then
          if FBeginX <> FEndX Or FBeginY <> FEndY then
              MoveWindow(FSelControl, FLeft + (FNewX - FBeginX), FTop + (FNewY - FBeginY), FWidth, FHeight, true)
          end if
       end if
    else
       P = type(X, Y)
       FOverControl = ChildWindowFromPoint(FDialog, P) 
       if OnMouseMove then OnMouseMove(this, X, Y, FOverControl)
       dim as integer Id = IsDot(FOverControl)
       if Id <> -1 then
          select case Id
          case 0 : SetCursor(crSizeNWSE)
          case 1 : SetCursor(crSizeNS)
          case 2 : SetCursor(crSizeNESW)
          case 3 : SetCursor(crSizeWE)
          case 4 : SetCursor(crSizeNWSE)
          case 5 : SetCursor(crSizeNS)
          case 6 : SetCursor(crSizeNESW)
          case 7 : SetCursor(crSizeWE)
          end select
       else
          if GetAncestor(FOverControl,GA_ROOTOWNER) <> FDialog then 
              ReleaseCapture
          end if    
          SetCursor(crArrow)
          ClipCursor(0)
       end if
    end if
    FEndX = FNewX
    FEndY = FNewY
end sub

sub TDesigner.MouseUp(X as integer, Y as Integer, Shift as integer)
    dim as RECT R
    if FDown then
        FDown = false 
        if FCanInsert then
           if (FBeginX > FEndX and FBeginY > FEndY) then
               swap FBeginX, FNewX
               swap FBeginY, FNewY
           end if
           if (FBeginX > FEndX and FBeginY < FEndY) then
               swap FBeginX, FNewX
           end if
           if (FBeginX < FEndX and FBeginY > FEndY) then
               swap FBeginY, FNewY
           end if
           DrawBox(Type<RECT>(FBeginX, FBeginY, FNewX, FNewY))
           if GetClassAcceptControls(GetClassName(FSelControl)) Then
               R.Left   = FBeginX
               R.Top    = FBeginY
               R.Right  = FNewX
               R.Bottom = FNewY
               MapWindowPoints(FDialog, FSelControl, cast(POINT ptr, @R), 2)
               if OnInsertingControl then 
                   OnInsertingControl(this, FClass, FStyleEx, FStyle, FID)
               end if    
               CreateControl(FClass, "", "", FSelControl, R.Left, R.Top, R.Right -R.Left, R.Bottom -R.Top)
           else
               if OnInsertingControl then 
                   OnInsertingControl(this, FClass, FStyleEx, FStyle, FID)
               end if
               CreateControl(FClass, "", "", FDialog, FBeginX, FBeginY, FNewX -FBeginX, FNewY -FBeginY)
           end If
           if FSelControl then
               BringWindowToTop(FSelControl)
               MoveDots(FSelControl)
               if OnInsertControl then OnInsertControl(this, FClass, FSelControl)
           end if
           FCanInsert = false
        end if
        if FCanSize then
            MoveDots(FSelControl)
            FCanSize = false
            if OnModified then OnModified(this, FSelControl)
        end If
        if FCanMove then
            MoveDots(FSelControl)
            FCanMove = false
            if OnModified then OnModified(this, FSelControl)
        end if
        FBeginX = FEndX
        FBeginY = FEndY
        FNewX   = FBeginX
        FNewY   = FBeginY
        ClipCursor(0)
        ReleaseCapture
    else
        ClipCursor(0)
    end if
end sub

sub TDesigner.DeleteControl(hDlg as HWND)
    if IsWindow(hDlg) then
        if hDlg <> FDialog then
           if OnDeleteControl then OnDeleteControl(this, hDlg)
           DestroyWindow(hDlg)
           if OnModified then OnModified(this, hDlg)
           HideDots
           FSelControl = FDialog
       end if
    end if
end sub

sub TDesigner.UnHookControl(Control as HWND)
    if IsWindow(Control) then
        if GetWindowLong(Control, GWL_WNDPROC) = @HookChildProc then
            SetWindowLong(Control, GWL_WNDPROC, cint(GetProp(Control, "@@@Proc")))
            RemoveProp(Control, "@@@Proc") 
        end if
    end if    
end sub

sub TDesigner.HookControl(Control as HWND)
    if IsWindow(Control) then
        if GetWindowLong(Control, GWL_WNDPROC) <> @HookChildProc then
          SetProp(Control, "@@@Proc", cast(WNDPROC, SetWindowLong(Control, GWL_WNDPROC, cint(@HookChildProc)))) 
        end if
    end if    
end sub

sub TDesigner.CreateControl(AClassName as string, AName as string, AText as string, AParent as HWND, x as integer,y as integer, cx as integer, cy as integer)
    FSelControl = CreateWindowEx(FStyleEx,_
                                 AClassName,_
                                 AText,_
                                 FStyle or WS_VISIBLE or WS_CHILD or WS_CLIPCHILDREN or WS_CLIPSIBLINGS,_
                                 x,_
                                 y,_
                                 iif(cx, cx, 50),_
                                 iif(cy, cy, 50),_
                                 AParent,_
                                 cast(HMENU, FID),_
                                 instance,_
                                 0)
    if IsWindow(FSelControl) then
        HookControl(FSelControl)
        'AName = iif(AName="", AName = AClassName & ...)
        'SetProp(Control, "Name", ...)
        'possibly using in propertylist inspector
        FClass = ""
    end if
end sub

sub TDesigner.UpdateGrid
    InvalidateRect(FDialog, 0, true)
end sub

sub TDesigner.DrawGrid(DC as HDC, R as RECT)
    dim as HDC mDc
    dim as HBITMAP mBMP, pBMP
    dim as RECT BrushRect = type(0, 0, FStepX, FStepY)
    if FGridBrush then 
        DeleteObject(FGridBrush)
    end if   
    mDc   = CreateCompatibleDc(DC)
    mBMP  = CreateCompatibleBitmap(DC, FStepX, FStepY)
    pBMP  = SelectObject(mDc, mBMP) 
    FillRect(mDc, @BrushRect, cast(HBRUSH, 16)) 
    SetPixel(mDc, 1, 1, 0) 
    'for lines use MoveTo and LineTo or Rectangle function or whatever...
    FGridBrush = CreatePatternBrush(mBMP)
    FillRect(DC, @R, FGridBrush)
    SelectObject(mDc, pBMP)
    DeleteObject(mBMP)
    DeleteDc(mDc)
end sub

function TDesigner.HookChildProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
    select case uMsg
    case WM_MOUSEFIRST to WM_MOUSELAST
        return true
    case WM_NCHITTEST
        return HTTRANSPARENT
    case WM_KEYFIRST to WM_KEYLAST 
        return 0
    end select
    return CallWindowProc(GetProp(hDlg, "@@@Proc"), hDlg, uMsg, wParam, lParam)
end function

function TDesigner.HookDialogProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
    dim as PDesigner Designer = GetProp(hDlg, "@@@Designer")
    if Designer then
        with *Designer
          select case uMsg
          case WM_ERASEBKGND
              dim as RECT R
              GetClientRect(hDlg, @R)
              if .FShowGrid then 
                  .DrawGrid(cast(HDC, wParam), R)
              else
                  FillRect(cast(HDC, wParam), @R, cast(HBRUSH, 16))
              end if    
              return 1
          case WM_LBUTTONDOWN
              .MouseDown(loWord(lParam), hiWord(lParam),wParam and &HFFFF )
              return 0
          case WM_LBUTTONUP
              .MouseUp(loWord(lParam), hiWord(lParam),wParam and &HFFFF )
              return 0
          case WM_MOUSEMOVE
              .MouseMove(loword(lParam), hiword(lParam),wParam and &HFFFF )
              return 0
          case WM_RBUTTONUP
              if .FSelControl <> .FDialog then
                  dim as POINT P
                  P.x = loWord(lParam)
                  P.y = hiWord(lParam)
                  ClientToScreen(hDlg, @P)
                  TrackPopupMenu(.FPopupMenu, 0, P.x, P.y, 0, hDlg, 0)
              end if
              return 0
          case WM_COMMAND
              if IsWindow(cast(HWND, lParam)) then
              else
                 if hiWord(wParam) = 0 then
                     select case loWord(wParam)
                     case 10: if .FSelControl<> .FDialog then .DeleteControl(.FSelControl)
                     case 11: MessageBox(.FDialog, "Not implemented yet.","Designer", 0)
                     case 12: MessageBox(.FDialog, "Not implemented yet.","Designer", 0)
                     case 13: MessageBox(.FDialog, "Not implemented yet.","Designer", 0)
                     case 15: MessageBox(.FDialog, "Not implemented yet.","Designer", 0)
                     end select
                 end if
              end if '
              ''''Call and execute the based commands of dialogue.
              return CallWindowProc(GetProp(hDlg, "@@@Proc"), hDlg, uMsg, wParam, lParam)
              '''if don't want to call
              'return 0
          end select
       end with
    end if
    return CallWindowProc(GetProp(hDlg, "@@@Proc"), hDlg, uMsg, wParam, lParam) 
end function

sub TDesigner.Hook
    if IsWindow(FDialog) then
        SetProp(FDialog, "@@@Designer", this)
        if GetWindowLong(FDialog, GWL_WNDPROC) <> @HookDialogProc then
           SetProp(FDialog, "@@@Proc", cast(any ptr, SetWindowLong(FDialog, GWL_WNDPROC, cint(@HookDialogProc))))
        end if
        GetChilds 
        for i as integer = 0 to FChilds.Count-1 
            HookControl(FChilds.Child[i])
        next 
    end if
end sub

sub TDesigner.UnHook
    SetWindowLong(FDialog, GWL_WNDPROC, cint(GetProp(FDialog, "@@@Proc")))
    RemoveProp(FDialog, "@@@Designer")
    RemoveProp(FDialog, "@@@Proc")
    GetChilds
    for i as integer = 0 to FChilds.Count-1
        UnHookControl(FChilds.Child[i])
    next
end sub

function TDesigner.DotWndProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
    dim as PDesigner Designer = cast(PDesigner, GetWindowLong(hDlg, 0))
    select case uMsg
    case WM_PAINT
        dim as PAINTSTRUCT Ps
        dim as HDC Dc
        Dc = BeginPaint(hDlg, @Ps)
        FillRect(Dc, @Ps.rcPaint, iif(Designer, Designer->FDotBrush, cast(HBRUSH, GetStockObject(BLACK_BRUSH))))
        EndPaint(hDlg, @Ps)
        return 0
        'or use WM_ERASEBKGND message 
    case WM_LBUTTONDOWN
        return 0
    case WM_NCHITTEST
        return HTTRANSPARENT
    case WM_DESTROY
        RemoveProp(hDlg,"@@@Control")
        return 0
    end select
    return DefWindowProc(hDlg, uMsg, wParam, lParam)
end function      

sub TDesigner.RegisterDotClass
   dim as WNDCLASSEX wcls
   wcls.cbSize        = sizeof(wcls)
   wcls.lpszClassName = @"Dot"
   wcls.lpfnWndProc   = @DotWndProc
   wcls.cbWndExtra   += 4
   wcls.hInstance     = instance
   RegisterClassEx(@wcls)
end sub

property TDesigner.Dialog as HWND
    return FDialog
end property

property TDesigner.Dialog(value as HWND)
    if value <> FDialog then
        UnHook
        FDialog = value
        if FActive then Hook
        InvalidateRect(FDialog, 0, true)
    end if    
end property

property TDesigner.Active as Boolean
    return FActive
end property

property TDesigner.Active(value as Boolean)
    if value <> FActive then
        FActive = value
        if value then 
           Hook
        else
           UnHook
           HideDots
        end if 
        InvalidateRect(FDialog, 0, true)
    end if
end property

property TDesigner.ChildCount as integer
    GetChilds
    return FChilds.Count
end property

property TDesigner.ChildCount(value as integer)
end property

property TDesigner.Child(index as integer) as HWND
    if index > -1 and index < FChilds.Count then
        return FChilds.Child[index]
    end if
    return 0
end property

property TDesigner.Child(index as integer,value as HWND)
end property

property TDesigner.StepX as integer
    return FStepX
end property

property TDesigner.StepX(value as integer)
    if value <> FStepX then
       FStepX = value
       UpdateGrid
    end if   
end property

property TDesigner.StepY as integer
    return FStepY
end property

property TDesigner.StepY(value as integer)
    if value <> FStepY then
       FStepY = value
       UpdateGrid
   end if
end property

property TDesigner.DotColor as integer
    dim as LOGBRUSH LB
    if GetObject(FDotBrush, sizeof(LB), @LB) then
        FDotColor = LB.lbColor
    end if
    return FDotColor
end property

property TDesigner.DotColor(value as integer)
    if value <> FDotColor then
        FDotColor = value
        if FDotBrush then DeleteObject(FDotBrush)
        FDotBrush = CreateSolidBrush(FDotColor)
        for i as integer = 0 to ubound(FDots)'-1
            InvalidateRect(FDots(i), 0, true)
        next
    end if
end property

property TDesigner.SnapToGrid as Boolean
    return FSnapToGrid
end property

property TDesigner.SnapToGrid(value as Boolean)
    FSnapToGrid = value
end property

property TDesigner.ShowGrid as Boolean
    return FShowGrid
end property

property TDesigner.ShowGrid(value as Boolean)
    FShowGrid = value
    if IsWindow(FDialog) then InvalidateRect(FDialog, 0, true)
end property

property TDesigner.ClassName as string
    return FClass
end property

property TDesigner.ClassName(value as string)
    FClass = value
end property

operator TDesigner.cast as any ptr
    return @this
end operator

constructor TDesigner(hDlg as HWND)
    Dialog      = hDlg
    FStepX      = 6
    FStepY      = 6
    FShowGrid   = true
    FActive     = true
    FSnapToGrid = 1
    FDotBrush   = CreateSolidBrush(FDotColor)
    RegisterDotClass
    CreateDots(hDlg)
    FPopupMenu  = CreatePopupMenu
    AppendMenu(FPopupMenu, MF_STRING, 10, @"Delete")
    AppendMenu(FPopupMenu, MF_SEPARATOR, -1, @"-")
    AppendMenu(FPopupMenu, MF_STRING, 12, @"Copy")
    AppendMenu(FPopupMenu, MF_STRING, 13, @"Cut")
    AppendMenu(FPopupMenu, MF_STRING, 14, @"Paste")
    AppendMenu(FPopupMenu, MF_SEPARATOR, -1, @"-")
    AppendMenu(FPopupMenu, MF_STRING, 15, @"Properties")
end constructor

destructor TDesigner
    UnHook
    DeleteObject(FDotBrush)
    DeleteObject(FGridBrush)
    DestroyMenu(FPopupMenu)
    DestroyDots
    UnregisterClass("Dot", instance)
end destructor

TinyDesigner.bas

Code: Select all

/'
This is an FreeBasic GUI Application
Generated by Skeleton 1.0
Nastasa Eodor
nastasa.eodor@gmail.com
http://rqwork.xhost.ro

'/

#include once "windows.bi"
#include once "win/commctrl.bi"
#include once "win/commdlg.bi"

#define instance GetModuleHandle(0)

common shared as HWND hAppHandle

#include once "designer.bi"

dim shared as TDesigner Designer = hAppHandle

sub MouseMove(Sender as TDesigner, X as integer, Y as integer, ByRef Over as HWND)
    dim as string s = "TinyDesigner [X: " & X & ", Y: " & Y & " Control: " & Over & "]"
    SetWindowText(hAppHandle, s)
end sub

Designer.OnMouseMove = @MouseMove

function myFBApplication_WindowProc(hDlg as HWND, Msg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
   select case Msg
        case WM_CREATE
           var hMenu   = CreateMenu
           var hFile   = CreatePopupMenu
           AppendMenu(hFile, MF_STRING, 10001, @"DesignTime Mode")
           AppendMenu(hFile, MF_STRING, 10002, @"RunTime Mode")
           AppendMenu(hFile, MF_SEPARATOR, -1, @"-")
           AppendMenu(hFile, MF_STRING, 10003, @"Snap To Grid")
           AppendMenu(hFile, MF_STRING, 10004, @"Show/Hide Grid")
           var hColor = CreatePopupMenu
           AppendMenu(hColor, MF_STRING, 101, @"Red")
           AppendMenu(hColor, MF_STRING, 102, @"Blue")
           AppendMenu(hColor, MF_STRING, 103, @"Gren")
           AppendMenu(hColor, MF_STRING, 104, @"Black")
           AppendMenu(hFile, MF_POPUP, cint(hColor), @"Dot Color")
           var hSize = CreatePopupMenu
           AppendMenu(hSize, MF_STRING, 105, @"3 x 3")
           AppendMenu(hSize, MF_STRING, 106, @"4 x 4")
           AppendMenu(hSize, MF_STRING, 107, @"6 x 6")
           AppendMenu(hSize, MF_STRING, 108, @"8 x 8")
           AppendMenu(hFile, MF_POPUP, cint(hSize), @"Grid Size")
           AppendMenu(hFile, MF_SEPARATOR, -1, @"-")
           AppendMenu(hFile, MF_STRING, 10005, @"Exit")
           var hEdit   = CreatePopupMenu
           AppendMenu(hEdit, MF_STRING, 10006, @"Button")
           AppendMenu(hEdit, MF_STRING, 10007, @"EditBox")
           AppendMenu(hEdit, MF_STRING, 10008, @"ComboBox")
           AppendMenu(hEdit, MF_STRING, 10009, @"TrackBar")
           AppendMenu(hEdit, MF_STRING, 10010, @"ToolBar")
           AppendMenu(hEdit, MF_STRING, 10011, @"TabControl")
           var hHelp   = CreatePopupMenu
           AppendMenu(hHelp, MF_STRING, 10012, @"About..")
           AppendMenu(hMenu, MF_POPUP, cint(hFile), @"Action")
           AppendMenu(hMenu, MF_POPUP, cint(hEdit), @"Classes")
           AppendMenu(hMenu, MF_POPUP, cint(hHelp), @"Help")
           SetMenu(hDlg, hMenu)
           DrawMenuBar(hDlg)
           CreateWindowEx(0,"BUTTON","Button",WS_CHILD OR WS_VISIBLE OR WS_CLIPSIBLINGS,10,10,75,35,hDlg,cast(HMENU,1001),instance,0)
           CreateWindowEx(512,"EDIT","Edit",WS_CHILD OR WS_VISIBLE OR WS_CLIPSIBLINGS,10,50,125,25,hDlg,cast(HMENU,1002),instance,0)
           CreateWindowEx(0,"SCROLLBAR","",WS_CHILD OR WS_VISIBLE OR WS_CLIPSIBLINGS,10,100,175,19,hDlg,cast(HMENU,1003),instance,0)
           return 0
        case WM_CLOSE
           select case MessageBox(hDlg,"Really close ?","myFBApplication",MB_YESNO OR MB_ICONERROR OR MB_TOPMOST OR MB_TASKMODAL)
               case IDYES
                   PostQuitMessage(0)
               case IDNO
                   return 1
           end select
           return 0
        case WM_COMMAND
           select case loword(wParam)
               case 10001
                   Designer.Dialog = hAppHandle
                   Designer.Active = true
               case 10002
                   Designer.Active = false
               case 10003
                   if Designer.SnapToGrid then
                       Designer.SnapToGrid = false
                   else
                       Designer.SnapToGrid = true
                   end if
               case 10004
                   if Designer.ShowGrid then
                       Designer.ShowGrid = false
                   else
                       Designer.ShowGrid = true 
                   end if 
               case 101 ' @"Red"
                   Designer.DotColor = &H0000FF
               case 102 ' @"Blue"
                   Designer.DotColor = &HFF0000
               case 103 ' @"Gren"
                   Designer.DotColor = &H00FF00
               case 104 ' @"Black"
                   Designer.DotColor = &H000000
               case 105 ' @"3 x 3"
                   Designer.StepX = 3
                   Designer.StepY = 3
               case 106 ' @"4 x 4"
                   Designer.StepX = 4
                   Designer.StepY = 4
               case 107 ' @"6 x 6"
                   Designer.StepX = 6
                   Designer.StepY = 6
               case 108 ' @"7 x 7"
                   Designer.StepX = 8
                   Designer.StepY = 8   
               case 10005
                   return SendMessage(hDlg,WM_CLOSE,0,0)
               case 10006
                   Designer.ClassName = "Button" 
               case 10007
                   Designer.ClassName = "Edit" 
               case 10008
                   Designer.ClassName = "ComboBox" 
               case 10009
                   Designer.ClassName = "msctls_trackbar32" 
               case 10010
                   Designer.ClassName = "ToolBarWindow32"    
               case 10011
                   Designer.ClassName = "SysTabControl32"
               case 10012    
                   MessageBox(hDlg,"TinyDesigner v 0.0"&chr(10)&_
                                   "This program was created for educational purposes to support the novice in the API and FreeBASIC."&chr(10)&_
                                   " You can change and improve to meet your needs."&chr(10)&_
                                   "(c)2013 Nastase Eodor"&chr(10)&_
                                   "http://rqwork.xhost.ro"&chr(10)&_
                                   "nastasa.eodor@gmail.com","Designer",_
                                   MB_ICONINFORMATION)
               case 1001 'Button Control
                   MessageBox(hDlg, "Hello ! I'm an tiny Designer.", "Designer", MB_ICONWARNING)
           end select
           return 0
   end select
   return DefWindowProc(hDlg, Msg, wParam, lParam)
end function

sub myFBApplication_CreateWindow
    hAppHandle = CreateWindowEx(WS_EX_APPWINDOW,"myFBApplication","myFBApplication",WS_OVERLAPPEDWINDOW OR WS_CLIPCHILDREN OR WS_CLIPSIBLINGS,200,200,500,350,0,0,instance,0)
    if IsWindow(hAppHandle) then
        ShowWindow(hAppHandle, SW_SHOW)
        UpdateWindow(hAppHandle)
    end if
end sub

sub myFBApplication_RegisterClass
    dim as WNDCLASSEX wcls
    wcls.cbSize        = sizeof(WNDCLASSEX)
    wcls.hInstance     = instance
    wcls.lpszClassName = @"myFBApplication"
    wcls.lpfnWndProc   = @myFBApplication_WindowProc
    wcls.hbrBackground = cast(HBRUSH, 16)
    wcls.hIcon         = LoadIcon(instance, "MAIN")
    wcls.hCursor       = LoadCursor(0, IDC_ARROW)
    wcls.lpszMenuName  = 0
    if RegisterClassEx(@wcls) = 0 then
        MessageBox(0,"Failed to register myFBApplication.","Application Error",MB_ICONERROR OR MB_TOPMOST OR MB_TASKMODAL)
    end if
end sub

/' Main  '/
myFBApplication_RegisterClass
myFBApplication_CreateWindow


dim as MSG uMsg    
while GetMessage(@uMsg, 0, 0, 0) > 0
    TranslateMessage(@uMsg)
    DispatchMessage(@uMsg)
wend

/'  Module  '/
sub Initialization constructor
    InitCommonControls
end sub

sub Finalization destructor
    UnregisterClass("myFBApplication", instance)
    ExitProcess(0)
end sub

eodor · Post by **eodor** » Nov 29, 2013 22:00

Another cake.

Code: Select all

/'
  tinyGUI wrapper for FreeBASIC
  (c)2013 Nastasa Eodor
  http://rqwork.xhost.ro
  mail: nastasa.eodor@gmail.com
'/

#include once "windows.bi"
#include once "win/commctrl.bi"

const LF = chr(10)

#define instance GetModuleHandle( 0 )

'user defined message
#define CM_COMMAND WM_APP + 100 

type PContainer as TContainer ptr

declare function GetGUIThreadInfo lib "user32" alias "GetGUIThreadInfo"(idThread as DWORD , lpgui as GUITHREADINFO ptr ) as Boolean
declare function MsgBox(ByRef Text as string, Kind as integer =0, ByRef Caption as string ="") as integer
    
type TMessage
    Handle  as HWND
    Msg     as UINT
    wParam  as WPARAM
    lParam  as LPARAM
    Result  as LRESULT
    Sender  as PContainer
end type

type TContainer extends Object
    dim               as HFONT Font
    dim               as HBRUSH Brush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
    dim               as HWND Handle, ParentWnd = 0
    dim               as integer StyleEx, Style, x, y, cx, cy
    dim               as string Text, Name
    dim               as string ClassName
    
    protected:
    declare static   function WindowProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
    declare           sub Dispatch(ByRef message as TMessage)
    declare abstract sub DefaultHandler(ByRef message as TMessage)
    declare abstract sub RegisterClass
    declare           sub CreateWindow
    declare           sub DestroyWindow
    declare           sub DeleteObjects
    
    public:
    Tag                as any ptr
    TagI               as integer
    TagS               as string
    declare           property Parent as HWND
    declare           property Parent(value as HWND)
    declare           operator cast as HWND
    declare           constructor
    declare           destructor
    OnCreate           as sub(Sender as TContainer)
    OnDestroy          as sub(Sender as TContainer)
    OnMenuCommand      as sub(Sender as TContainer, ID as integer)
    OnAccelCommand     as sub(Sender as TContainer, ID as integer)
end type

type TFrame extends TContainer
    dim              as string MenuName = "MAINMENU"
    dim              as HMENU Menu, PopupMenu
    
    protected:
    declare          sub ApplicationMessage(ByRef message as TMessage)
    declare virtual sub DefaultHandler(ByRef message as TMessage)
    declare virtual sub RegisterClass
    
    public:
    declare          sub Run
    declare          sub Terminate
    declare          sub Close
    declare          operator cast as HWND
    declare          constructor
    declare          destructor
    OnAppMessage      as sub(ByRef message as TMessage)
    OnShow            as sub(Sender as TFrame)
    OnClose           as sub(Sender as TFrame, ByRef Action as integer) 
end type

type TControl extends TContainer
    dim              as HMENU PopupMenu
    
    protected:
    declare virtual sub DefaultHandler(ByRef message as TMessage)
    declare virtual sub RegisterClass
    
    public:
    dim               as Rect ClientRect
    dim               as HDC Canvas
    declare          operator cast as HWND
    declare          constructor
    declare          destructor
    OnPaint           as sub(Sender as TControl)
end type

type TButton extends TControl
    dim              as integer ButtonStyle
    
    private:
    declare          function ClassProc as WNDPROC
    
    protected:
    declare virtual sub DefaultHandler(ByRef message as TMessage)
    declare virtual sub RegisterClass
    
    public:
    declare          sub Click
    declare          operator cast as HWND
    declare          constructor
    declare          destructor
    OnClick           as Sub(Sender as TButton)
end type

''''MsgBox
function MsgBox(ByRef Text as string, Kind as integer =0, ByRef Caption as string ="") as integer
    dim as GUITHREADINFO tif
    tif.cbSize = sizeof(tif)
    GetGUIThreadInfo(0, @tif)
    if Caption = "" then
        Caption = string(255, 0)
        GetModuleFileName(0, Caption, 255)
        Caption = trim(mid(Caption, instrrev(Caption, "\")+1, len(Caption)))
    end if    
    return MessageBox(tif.hwndActive, Text, Caption, MB_TOPMOST or MB_APPLMODAL or Kind)
end function

'''TContainer
function TContainer.WindowProc(hDlg as HWND, uMsg as UINT, wParam as WPARAM, lParam as LPARAM) as LRESULT
    dim as TContainer ptr Container = NULL
    dim as TMessage message = type( hDlg, uMsg, wParam, lParam, -1, Container )
    if uMsg = WM_NCCREATE then
        Container = cast( TContainer ptr, cast(LPCREATESTRUCT, lParam)->lpCreateParams )
        if Container then
            Container->Handle = hDlg
            SetWindowLong( hDlg, GetClassLong(hDlg, GCL_CBWNDEXTRA)-4, cint(Container) )
        else
            MessageBox( 0, "No linked object.", "Creation Error", MB_TOPMOST or MB_TASKMODAL or MB_ICONERROR ) 
        end if
    else
        Container = cast( TContainer ptr, GetWindowLong( hDlg, GetClassLong(hDlg, GCL_CBWNDEXTRA)-4 ))
    end if
    if Container then
        Container->Dispatch( message )
        return message.Result
    end if    
    return message.Result
end function

sub TContainer.Dispatch(ByRef message as TMessage)
    select case message.Msg
    case WM_CREATE
        if OnCreate then OnCreate(this)
        message.Result = false 
    case WM_DESTROY
        if OnDestroy then OnDestroy(this)
        message.Result = false
    case WM_COMMAND
        dim as integer CtlType = hiWord(message.wParam)
        if IsWindow(cast(HWND, message.lParam)) then
            SendMessage(cast(HWND, message.lParam), CM_COMMAND, hiWord(message.wParam), cint(Handle)) 
        else
           if CtlType = 0 then
               if loWord(message.wParam) < &H00FF then
                    DefaultHandler(message)
                    exit sub
               else
                   if OnMenuCommand then OnMenuCommand(this,loWord(message.wParam)) 
               end if
           elseif CtlType = 1 then
               if OnAccelCommand then OnAccelCommand(this,loWord(message.wParam)) 
           end if
        end if
        message.Result = false
    end select    
    DefaultHandler(message)
end sub

sub TContainer.CreateWindow
    CreateWindowEx(StyleEx, ClassName, Text, Style, x, y, cx, cy, ParentWnd, 0, instance,  @this)
    if IsWindow(Handle) then
        SendMessage(Handle, WM_SETFONT, cint(Font), true)
    end if
end sub

sub TContainer.DestroyWindow
    if IsWindow(Handle) then
        .DestroyWindow(Handle)
        Handle = 0
    end if
end sub

sub TContainer.DeleteObjects
    if Brush then DeleteObject(Brush)
    if Font  then DeleteObject(Font)
end sub

property TContainer.Parent as HWND
    return ParentWnd
end property

property TContainer.Parent(value as HWND)
    ParentWnd = value
    if IsWindow(Handle) then
        SetParent(Handle, value)
    else
        CreateWindow
    end if
end property

operator TContainer.cast as HWND
    return Handle
end operator

constructor TContainer
    dim as LOGFONT LF
    If GetObject(GetStockObject(DEFAULT_GUI_FONT), sizeof(LF), @LF) then
        Font = CreateFontIndirect(@LF)
    end if
end constructor

destructor TContainer
    DeleteObjects
    DestroyWindow
end destructor

''''TFrame
sub TFrame.DefaultHandler(ByRef message as TMessage)
    select case message.Msg
    case WM_SHOWWINDOW
        if message.wParam then
            if OnShow then OnShow(this)
        end if
        message.Result = false
    case WM_CLOSE
        dim as integer Action
        if OnClose then OnClose(this, Action)
        if Action then
            select case Action
            case 2 : ShowWindow(Handle, SW_HIDE)
            Case 3 : ShowWindow(Handle, SW_MINIMIZE)
            end select
            message.Result = Action
            exit sub
        end if
        message.Result = false
    end select
    message.Result = DefWindowProc(message.Handle, message.Msg, message.wParam, message.lParam)
end sub

sub TFrame.ApplicationMessage(ByRef message as TMessage)
    if OnAppMessage then OnAppMessage(message)
end sub

sub TFrame.Run
    dim as MSG uMsg
    while GetMessage(@uMsg, 0, 0, 0) > 0
        dim as TMessage Msg = type(uMsg.hWnd, uMsg.message, uMsg.wParam, uMsg.lParam)
        ApplicationMessage( Msg )
        TranslateMessage( @uMsg )
        DispatchMessage( @uMsg )
    wend    
end sub

sub TFrame.Close
    SendMessage(Handle, WM_CLOSE, 0, 0)
end sub

sub TFrame.Terminate
    ExitProcess(0)
end sub

sub TFrame.RegisterClass
    dim as WNDCLASSEX wcls
    wcls.cbSize        = sizeof(wcls)
    wcls.style         = CS_DBLCLKS or CS_OWNDC
    wcls.hInstance     = instance
    wcls.cbWndExtra   += 4
    wcls.cbClsExtra   += 4
    wcls.hbrBackground = Brush
    wcls.lpszClassName = strptr(ClassName)
    wcls.lpfnWndProc   = @WindowProc
    wcls.lpszMenuName  = strptr(MenuName)
    wcls.hCursor       = LoadCursor( 0, IDC_ARROW )
    RegisterClassEx( @wcls )
end sub

operator TFrame.cast as HWND
    return Handle
end operator

constructor TFrame
     ClassName = "TFrame" 
     Style     = WS_OVERLAPPEDWINDOW or WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS
     cx        = 350
     cy        = 250'
     this.RegisterClass
end constructor

destructor TFrame
end destructor

''''TControl
sub TControl.DefaultHandler(ByRef message as TMessage)
    select case message.Msg
    case WM_PAINT
        dim as PAINTSTRUCT ps
        Canvas = BeginPaint(Handle, @ps)
        ClientRect = ps.rcPaint
        if OnPaint then OnPaint(this)
        EndPaint(Handle, @ps)
        Canvas = 0
        ClientRect = type(0, 0, 0, 0)
        message.Result = false
    end select
    message.Result = DefWindowProc(message.Handle, message.Msg, message.wParam, message.lParam)
end sub

sub TControl.RegisterClass
    dim as WNDCLASSEX wcls
    wcls.cbSize        = sizeof(wcls)
    wcls.style         = CS_DBLCLKS or CS_OWNDC or CS_HREDRAW or CS_VREDRAW
    wcls.hInstance     = instance
    wcls.cbWndExtra   += 4
    wcls.cbClsExtra   += 4
    wcls.hbrBackground = Brush
    wcls.lpszClassName = strptr(ClassName)
    wcls.lpfnWndProc   = @WindowProc
    wcls.lpszMenuName  = 0
    wcls.hCursor       = LoadCursor( 0, IDC_ARROW )
    RegisterClassEx( @wcls )
end sub

operator TControl.cast as HWND
    return Handle
end operator

constructor TControl
     ClassName = "TControl"
     StyleEx   = WS_EX_STATICEDGE
     Style     = WS_CHILD or WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS
     cx        = 150
     cy        = 150
     this.RegisterClass
end constructor

destructor TControl
end destructor


''''TButton
function TButton.ClassProc as WNDPROC
    dim as WNDCLASSEX  wcls
    wcls.cbSize  = sizeof(wcls)
    if GetClassInfoEx(0, "Button", @wcls) then
        return wcls.lpfnWndProc
    end if
end function

sub TButton.DefaultHandler(ByRef message as TMessage)
    select case message.Msg
    case CM_COMMAND 
        if message.wParam = BN_CLICKED then
            Click
        end if    
        message.Result = false
    end select
    message.Result = CallWindowProc(ClassProc,message.Handle, message.Msg, message.wParam, message.lParam)
end sub

sub TButton.Click
    if OnClick then OnClick(this)
end sub

sub TButton.RegisterClass
    dim as WNDCLASSEX wcls
    wcls.cbSize  = sizeof(wcls)
    if GetClassInfoEx(0, "Button", @wcls) then
        wcls.hInstance     = instance
        wcls.cbWndExtra   += 4
        wcls.cbClsExtra   += 4
        wcls.lpszClassName = strptr(ClassName)
        wcls.lpfnWndProc   = @WindowProc
        RegisterClassEx( @wcls )
    end if    
end sub

operator TButton.cast as HWND
    return Handle
end operator

constructor TButton
     ClassName = "TButton"
     StyleEx   = 0
     Style     = BS_PUSHLIKE or WS_CHILD or WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS
     cx        = 75
     cy        = 35
     this.RegisterClass
end constructor

destructor TButton
end destructor

''''''''''''
''''TEST''''
''''''''''''
'here is the .rc
'MAINMENU MENU
'BEGIN
'  POPUP "File"
'  BEGIN
'     MENUITEM "New Frame",  10000
'     MENUITEM "Delete All", 10001
'     MENUITEM SEPARATOR
'     MENUITEM "Exit", 10002
'  END
'  MENUITEM "About",   10003
'END
'
'NEWMENU MENU
'BEGIN
'  POPUP "Help"
'  BEGIN
'     MENUITEM "About",   10003
'  END
'END

dim as TFrame Frame , Child
dim as TControl Control
dim as TButton Button

'''Events
sub ControlPaint(sender as TControl)
    Rectangle(sender.Canvas, 50, 30, 100, 100)
end sub

sub ButtonClick(Sender as TButton)
    'MessageBox(0,"Hello ! I'm clicked.","Button", 0)
    'MsgBox("Hello ! I'm clicked.",, "Button")
    MsgBox("Hello ! I'm clicked.")
end sub

sub FrameCreate(sender as TContainer)
    CreateWindowEx(0, "msctls_trackbar32", "", WS_CHILD or WS_VISIBLE, 160, 20, 100, 35, sender.Handle, cast(HMENU, 1001), instance, 0)
    MoveWindow(sender.Handle, 400, 400, 450, 250, true)
    MsgBox("Hi ! I'm a tinyGUI wrapper for FreeBasic.",MB_ICONINFORMATION)
end sub

sub FrameClose(sender as TFrame, ByRef Action as integer)
    if MsgBox("Close ?",MB_YESNO) = IDNO then
       Action = 1
    else
        PostQuitMessage(0)
        'sender.Terminate 
    end if  
end sub

        type TFrameList
            as integer count
            as TFrame ptr ptr Frames
        end type
        dim shared as TFrameList List
        
sub FrameMenuCommand(sender as TContainer, idCommand as integer)
    select case idCommand
    case 10000
        List.count += 1
        List.Frames = reallocate(List.FRames,List.count*sizeof(TFrame ptr))
        List.Frames[List.count-1]=New TFrame
        with *(List.Frames[List.count-1])
            .Parent=Sender
            MoveWindow(*(List.Frames[List.count-1]),List.Count*15,List.Count*15,200,150,true)
        end with    
    case 10001
        'MsgBox "" & idCommand
        for i as integer=List.count-1 to 0 step-1
            delete List.Frames[i]
        next
        delete List.Frames
        List.count=0
    case 10002
        *cast(TFrame ptr, @sender).Close
    case 10003
        MsgBox "tinyGUI wrapper for FreeBASIC ."&lf &"(c)2013 Nastase Eodor"& lf &"nastasa.eodor@gmail.com", MB_ICONINFORMATION
    end select    
end sub

sub FrameDestroy(sender as TContainer)
    for i as integer=List.count-1 to 0 step-1
         delete List.Frames[i]
    next
    delete List.Frames
end sub

sub ChildClose(sender as TFrame, ByRef Action as integer)
    sender.Menu=LoadMenu(instance,"NEWMENU")
    SetMenu(sender.Handle,sender.Menu)
    DrawMenuBar(sender.Handle)
    Action = 3
end sub

'''IMPL
Frame.OnCreate=@FrameCreate
Frame.OnClose=@FrameClose
Frame.OnMenuCommand=@FrameMenuCommand
Frame.OnDestroy=@FrameDestroy
Frame .Parent=0

Child.OnClose=@ChildClose
Child.Parent=Frame

Control.OnPaint=@ControlPaint
Control.Parent=Frame

Button.Text="Click me!"
Button.Parent=Child
Button.OnClick=@ButtonClick

Frame.Run

 
sub Initialization constructor
    InitCommonControls
    MsgBox "tinyGUI is initialized.", MB_ICONINFORMATION
end sub

sub Finalization destructor
    MsgBox "tinyGUI is finalized.", MB_ICONINFORMATION
end sub

TinyDesigner - small Form Designer

TinyDesigner - small Form Designer

Re: TinyDesigner - small Form Designer