FreeBasic

Пример позволяет рисовать эллипсы, прямоугольники, линии, кнопки с помощью мыши. Может пригодиться как часть программы по созданию редактора графики.

Платформа: Windows
Автор: Nastase Eodor

'2007 Nastase Eodor
'nastase_eodor@yahoo.com
'some graphical test

#INCLUDE "Windows.bi"
#INCLUDE "Win/CommCtrl.bi"

Enum TShapeKind
    skLine,skRectangle,skEllipse,skButton
End Enum

Type TShape
    Private:
    FKind         As TShapeKind
    FColor        As Integer
    FBrush        As HBRUSH
    FPenSize      As Integer
    FPenStyle     As Integer
    FBrushStyle   As Integer
    FBrushHatched As Boolean
    Public:
    Collection  As Any Ptr
    TopMost     As Boolean
    SPoint      As Point
    EPoint      As Point
    Declare Property Kind As TShapeKind
    Declare Property Kind(Value As TShapeKind)
    Declare Property Color As Integer
    Declare Property Color(Value As Integer)
    Declare Sub Paint(Dc As HDC)
    Declare Sub Move(x As Integer,y As Integer)
    Declare Sub BringToFront
    Declare Operator Cast As Any Ptr
    Declare Constructor
    OnMouseDown As Sub(Byref Shape As TShape,B As Integer,x As Integer,y As Integer)
    OnMouseUp   As Sub(Byref Shape As TShape,B As Integer,x As Integer,y As Integer)
    OnMouseMove As Sub(Byref Shape As TShape,x As Integer,y As Integer) 
End Type

Type TShapes
    Parent As HWND
    Count  As Integer
    Items As TShape Ptr Ptr
    Declare Sub Add(Shape As TShape Ptr)
    Declare Sub Remove(Shape As TShape Ptr)
    Declare Sub Exchange(Index1 As Integer,Index2 As Integer)
    Declare Function IndexOf(Shape As TShape Ptr) As Integer
    Declare Destructor
End Type

Property TShape.Kind As TShapeKind
    Return FKind
End Property

Property TShape.Kind(Value As TShapeKind)
    If Value <> FKind Then
        FKind = Value
    End If
End Property

Property TShape.Color As Integer
    Return FColor
End Property

Property TShape.Color(Value As Integer)
    Static As TShapes Ptr SL
    Dim As RECT R = Type(SPoint.x,SPoint.y,EPoint.x,EPoint.y)
    SL = Cast(TShapes Ptr,Collection)
    If Value <> FColor Then
        FColor = Value
        If FBrush Then DeleteObject FBrush
        FBrush = CreateSolidBrush(FColor)
        If SL Then RedrawWindow (SL->Parent,@R,0,RDW_ERASE Or RDW_INVALIDATE)
    End If    
End Property

Sub TShape.Paint(Dc As HDC)
    Select Case Kind
    Case skRectangle
        Dim As HBRUSH oldBrush
        oldBrush = SelectObject(Dc,FBrush)
        Rectangle Dc,SPoint.x,SPoint.y,EPoint.x,EPoint.y 
        SelectObject(Dc,oldBrush)
    Case skEllipse
        Dim As HBRUSH oldBrush
        oldBrush = SelectObject(Dc,FBrush)
        Ellipse Dc,SPoint.x,SPoint.y,EPoint.x,EPoint.y 
        SelectObject(Dc,oldBrush)
    Case skButton
        Dim As HBRUSH oldBrush
        Dim As RECT R = Type(SPoint.x,SPoint.y,EPoint.x,EPoint.y)
        oldBrush = SelectObject(Dc,FBrush)
        DrawFrameControl(DC,@R,DFC_BUTTON,DFCS_BUTTONPUSH Or DFCS_ADJUSTRECT)        
        SelectObject(Dc,oldBrush)
    Case skLine
        MoveToEx Dc,SPoint.x,SPoint.y,0
        LineTo Dc,EPoint.x,EPoint.y
    End Select
End Sub

Sub TShape.Move(x As Integer,y As Integer)
    Static As TShapes SL
    SL = *Cast(TShapes Ptr,Collection)
    SPoint.x += x
    SPoint.y += y
    EPoint.x += x
    EPoint.y += y
    RedrawWindow SL.Parent,0,0,RDW_ERASE Or RDW_INVALIDATE
End Sub

Sub TShape.BringToFront
    Dim As Integer i
    Static As TShapes Ptr SL
    SL = Cast(TShapes Ptr,Collection)
    For i = 0 To SL->Count -1
        SL->Items[i]->TopMost = 0
    Next i
    SL->Items[SL->IndexOF(@This)]->TopMost = 1
    If SL Then RedrawWindow SL->Parent,0,0,RDW_ERASE Or RDW_INVALIDATE
End Sub

Operator TShape.Cast As Any Ptr
    Return @This
End Operator

Constructor TShape
    FColor = &HFFFFFF
    FBRush = CreateSolidBrush(FColor)
End Constructor

Sub TShapes.Add(Shape As TShape Ptr)
    Count += 1
    Items = Reallocate(Items,Sizeof(TShape)*Count)
    Items[Count -1] = Shape
    Items[Count -1]->Collection = @This
    ReDrawWindow Parent,0,0,RDW_INVALIDATE Or RDW_ERASE
End Sub

Sub TShapes.Remove(Shape As TShape Ptr)
    Dim As Integer i,Index
    Dim As TShape Ptr S
    Index = IndexOF(Shape)
    If Index <> -1 Then
        For i = Index + 1 To Count -1
            S = Items[i -1]
            Items[i] = S
        Next i
        Count -= 1
        Items = Reallocate(Items,Sizeof(TShape)*Count)
    End If
End Sub

Function TShapes.IndexOf(Shape As TShape Ptr) As Integer 
    Dim As Integer i
    For i = 0 To Count -1
        If Items[i] = Shape Then Return i
    Next i
    Return -1
End Function

Sub TShapes.Exchange(Index1 As Integer,Index2 As Integer)
    Dim As TShape Ptr It
    It = Items[Index1]
    Items[Index1] = Items[Index2]
    Items[Index2] = It
    ReDrawWindow Parent,0,0,RDW_INVALIDATE Or RDW_ERASE
End Sub

Destructor TShapes
    If Items Then Deallocate Items
End Destructor

Type TForm
    Private:
    M             As MSG
    Instance      As HINSTANCE
    FText         As String
    FLeft         As Integer
    FTop          As Integer
    FWidth        As Integer
    FHeight       As Integer
    FClientWidth  As Integer
    FClientHeight As Integer
    Declare Sub DoCreate
    Declare Sub DoPaint
    Declare Sub DoCommand(Code As Integer,ID As Integer,FWindow As HWND)
    Declare Sub DoMouseDown(button As Integer,x As Integer,y As Integer,Shift As Integer)
    Declare Sub DoMouseUp(button As Integer,x As Integer,y As Integer,Shift As Integer)
    Declare Sub DoMouseMove(x As Integer,y As Integer,Shift As Integer)
    Declare Sub DoKeyDown(Key As Integer,Shift As Integer)
    Declare Sub DoKeyUp(Key As Integer,Shift As Integer)
    Declare Sub DoKeyPress(Key As Byte,Shift As Integer)
    Declare Static Function DefWndProc(FWindow As HWND,Msg As UINT,wParam As WPARAM,lParam As LPARAM) As LRESULT
    Declare Sub WndProc(FWindow As HWND,Msg As UINT,wParam As WPARAM,lParam As LPARAM)
    Declare Sub CreateWnd
    Public:
    MouseCapture  As Boolean
    ShapeCount    As Integer
    Shapes        As TShapes
    Handle        As HWND
    MainMenu      As HMENU 
    Declare Property Text As String
    Declare Property Text(Value As String)
    Declare Property Left As Integer
    Declare Property Left(Value As Integer)
    Declare Property Top As Integer
    Declare Property Top(Value As Integer)
    Declare Property Width As Integer
    Declare Property Width(Value As Integer)
    Declare Property Height As Integer
    Declare Property Height(Value As Integer)
    Declare Property ClientWidth As Integer
    Declare Property ClientHeight As Integer
    Declare Sub Run
    Declare Sub Terminate
    Declare Constructor
    Declare Destructor
    OnCommand   As Sub(Byref Sender As TForm,Code As Integer,ID As Integer,FWindow As HWND)
    OnMouseDown As Sub(Byref Sender As TForm,button As Integer,x As Integer,y As Integer,Shift As Integer)
    OnMouseMove As Sub(Byref Sender As TForm,x As Integer,y As Integer,Shift As Integer)
    OnMouseUp   As Sub(Byref Sender As TForm,button As Integer,x As Integer,y As Integer,Shift As Integer)
End Type

Property TForm.Text As String
    Dim As String Buff
    Dim As Integer L
    If Handle Then
       L = GetWindowTextLength(Handle) +1 
       Buff = String(L,0)
       GetWindowText(Handle,Buff,L)
    Else
        Return FText
    End If
End Property

Property TForm.Text(Value As String)
    FText = Value
    If Handle Then SetWindowText Handle,FText
End Property

Property TForm.Left As Integer
    Return FLeft
End Property

Property TForm.Left(Value As Integer)
    FLeft = Value
    If Handle Then MoveWindow Handle,FLeft,FTop,FWidth,FHeight,True
End Property

Property TForm.Top As Integer
    Return FTop
End Property

Property TForm.Top(Value As Integer)
    FTop = Value
    If Handle Then MoveWindow Handle,FLeft,FTop,FWidth,FHeight,True
End Property

Property TForm.Width As Integer
    Return FWidth
End Property

Property TForm.Width(Value As Integer)
    FWidth = Value
    If Handle Then MoveWindow Handle,FLeft,FTop,FWidth,FHeight,True
End Property

Property TForm.Height As Integer
    Return FHeight 
End Property

Property TForm.Height(Value As Integer)
    FHeight = Value
    If Handle Then MoveWindow Handle,FLeft,FTop,FWidth,FHeight,True
End Property

Property TForm.ClientWidth As Integer
    Dim As Rect R
    GetClientRect Handle,@R
    FClientWidth = R.Right
    Return FClientWidth
End Property

Property TForm.ClientHeight As Integer
    Dim As Rect R
    GetClientRect Handle,@R
    FClientHeight = R.Bottom
    Return FClientHeight 
End Property

Sub TForm.DoCreate
    MainMenu = CreateMenu
    DrawMenuBar Handle
    SetMenu Handle,MainMenu
End Sub

Sub TForm.DoCommand(Code As Integer,ID As Integer,FWindow As HWND)
    If OnCommand Then OnCommand(This,Code,Id,FWindow)
End Sub

Sub TForm.DoMouseDown(button As Integer,x As Integer,y As Integer,Shift As Integer)
    Dim As Point P
    Dim As Rect R
    Dim As Integer i
    If MouseCapture = 0 Then 
       P = Type(x,y)
       For i = Shapes.Count -1 To 0 Step -1
            R = Type(Shapes.Items[i]->SPoint.x,Shapes.Items[i]->SPoint.Y,Shapes.Items[i]->EPoint.x,Shapes.Items[i]->EPoint.Y)
            If PtInRect(@R,P) Then 'or pointinpolygon or ...
               If Shapes.Items[i]->OnMouseDown Then Shapes.Items[i]->OnMouseDown(*Shapes.Items[i],button,P.x-Shapes.Items[i]->SPoint.x,P.y-Shapes.Items[i]->SPoint.y)
               Exit Sub
            End If    
       Next i
    End If
    If OnMouseDown Then OnMouseDown(This,button,x,y,Shift)
End Sub

Sub TForm.DoMouseUp(button As Integer,x As Integer,y As Integer,Shift As Integer)
    Dim As Point P
    Dim As Rect R
    Dim As Integer i
    If MouseCapture = 0 Then 
       P = Type(x,y)
       For i = Shapes.Count -1 To 0 Step -1
            R = Type(Shapes.Items[i]->SPoint.x,Shapes.Items[i]->SPoint.Y,Shapes.Items[i]->EPoint.x,Shapes.Items[i]->EPoint.Y)
            If PtInRect(@R,P) Then 'or pointinpolygon or ...
               If Shapes.Items[i]->OnMouseUp Then Shapes.Items[i]->OnMouseUp(*Shapes.Items[i],button,P.x-Shapes.Items[i]->SPoint.x,P.y-Shapes.Items[i]->SPoint.y)
               Exit Sub
            End If    
       Next i
    End If
    If OnMouseUp Then OnMouseUp(This,button,x,y,Shift)
End Sub

Sub TForm.DoMouseMove(x As Integer,y As Integer,Shift As Integer)
    Dim As Point P
    Dim As Rect R
    Dim As Integer i
    If MouseCapture = 0 Then 
       P = Type(x,y)
       For i = Shapes.Count -1 To 0 Step -1
            R = Type(Shapes.Items[i]->SPoint.x,Shapes.Items[i]->SPoint.Y,Shapes.Items[i]->EPoint.x,Shapes.Items[i]->EPoint.Y)
            If PtInRect(@R,P) Then 'or pointinpolygon or ...
               If Shapes.Items[i]->OnMouseMove Then Shapes.Items[i]->OnMouseMove(*Shapes.Items[i],P.x-Shapes.Items[i]->SPoint.x,P.y-Shapes.Items[i]->SPoint.y)
               Exit Sub
            End If    
       Next i
    End If
    If OnMouseMove Then OnMouseMove(This,x,y,Shift)
End Sub

Sub TForm.DoKeyDown(Key As Integer,Shift As Integer)
End Sub

Sub TForm.DoKeyUp(Key As Integer,Shift As Integer)
End Sub

Sub TForm.DoKeyPress(Key As Byte,Shift As Integer)
End Sub

Sub TForm.DoPaint
    Dim As Integer i
    Dim As Rect R
    Dim As PAINTSTRUCT Ps
    Dim As HDC Dc,MemDC
    Dim As HBITMAP Bmp
    Dim As TShape Ptr ST
    GetClientRect Handle,@R
    Dc = BeginPaint(Handle,@Ps)
    MemDC = CreateCompatibleDC(DC)
    Bmp   = CreateCompatibleBitmap(DC,R.Right,R.Bottom)
    SelectObject(MemDc,Bmp)
    SendMessage(Handle,WM_ERASEBKGND, Cint(MemDC), Cint(MemDC))
    For i = 0 To Shapes.Count -1
        If *(Shapes.Items[i]).TopMost Then ST = Shapes.Items[i]
        If *(Shapes.Items[i]).TopMost = 0 Then *(Shapes.Items[i]).Paint(memDc)
    Next i
    If ST Then ST->Paint(memDc)
    BitBlt(DC, 0, 0, R.Right, R.Bottom, MemDC, 0, 0, SRCCOPY)
    DeleteObject(Bmp)
    DeleteDC(MemDC)
    EndPaint Handle, @Ps
End Sub

Sub TForm.WndProc(FWindow As HWND,Msg As UINT,wParam As WPARAM,lParam As LPARAM)
    Select Case Msg
    Case WM_PAINT 
        DoPaint
    Case WM_CLOSE
        PostQuitMessage 0
    Case WM_COMMAND
        DoCommand(Hiword(wParam),Loword(wParam),Cptr(HWND,lParam))
    Case WM_LBUTTONDOWN
        DoMouseDown(0,Loword(lParam),Hiword(lParam),wParam And &HFFFF)
    Case WM_RBUTTONDOWN
        DoMouseDown(1,Loword(lParam),Hiword(lParam),wParam And &HFFFF)
    Case WM_MBUTTONDOWN
        DoMouseDown(2,Loword(lParam),Hiword(lParam),wParam And &HFFFF)    
    Case WM_LBUTTONUP
        DoMouseUp(0,Loword(lParam),Hiword(lParam),wParam And &HFFFF)
    Case WM_RBUTTONUP
        DoMouseUp(1,Loword(lParam),Hiword(lParam),wParam And &HFFFF) 
    Case WM_MBUTTONUP
        DoMouseUp(2,Loword(lParam),Hiword(lParam),wParam And &HFFFF)    
    Case WM_MOUSEMOVE
        DoMouseMove(Loword(lParam),Hiword(lParam),wParam And &HFFFF)    
    End Select 
End Sub

Function TForm.DefWndProc(FWindow As HWND,Msg As UINT,wParam As WPARAM,lParam As LPARAM) As LRESULT
    Dim As TForm Ptr F
    F = Cast(TForm Ptr,GetWindowLong(FWindow,GWL_USERDATA))
    If F Then F->WndProc(FWindow,Msg,wParam,lParam)
    Return DefWindowProc(FWindow,Msg,wParam,lParam)
End Function

Sub TForm.CreateWnd
    Handle = CreateWindowEx(0,_
                            "TForm",_
                            "Form",_
                            WS_OVERLAPPEDWINDOW Or WS_CLIPSIBLINGS Or WS_CLIPCHILDREN Or WS_VISIBLE ,_
                            FLeft,_
                            FTop,_
                            FWidth,_
                            FHeight,_
                            0,_
                            0,_
                            Instance,_
                            0)
    If Handle Then
        SetWindowLong Handle,GWL_USERDATA, Cint(@This)
    End If
End Sub

Sub TForm.Run
    While GetMessage(@M,0,0,0)
       DispatchMessage @M
       TranslateMessage @M
    Wend
    End
End Sub

Sub TForm.Terminate
    PostQuitMessage 0
    End
End Sub

Constructor TForm
    Dim As WNDCLASS Wc
    InitCommonControls
    Instance = GetModuleHandle(NULL)
    If GetClassInfo(Instance,"TForm",@Wc) = 0 Then
        Wc.hInstance     = GetModuleHandle(NULL)
        Wc.hbrBackground = Cast(HBRUSH,16)
        Wc.hCursor       = LoadCursor(NULL,IDC_ARROW)
        Wc.lpszClassName = Strptr("TForm")
        Wc.lpfnWndProc   = @DefWndProc
        RegisterClass(@Wc)
    End If
    FWidth   = 700
    FHeight  = 500
    CreateWnd
    DoCreate
    Shapes.Parent = Handle
End Constructor

Destructor TForm
    UnregisterClass "TForm", GetModuleHandle(NULL)
    If Handle Then DestroyWindow Handle
End Destructor

''''''''Sample
Declare Sub ShapeMouseDown(Sender As TShape,b As Integer,x As Integer,y As Integer)
Declare Sub ShapeMouseMove(Sender As TShape,x As Integer,y As Integer)
Declare Sub ShapeMouseUp(Sender As TShape,x As Integer,y As Integer)

Declare Sub FormCommand(Sender As TForm,Code As Integer,ID As Integer,FWindow As HWND)
Declare Sub FormMouseDown(Sender As TForm,b As Integer,x As Integer,y As Integer,Shift As Integer)
Declare Sub FormMouseMove(Sender As TForm,x As Integer,y As Integer,Shift As Integer)
Declare Sub FormMouseUp(Sender As TForm,b As Integer,x As Integer,y As Integer,Shift As Integer)

Dim Shared As TShape Ptr Shape

Dim Shared As TForm Form
Form.OnCommand   = @FormCommand
Form.OnMouseDown = @FormMouseDown
Form.OnMouseMove = @FormMouseMove
Form.OnMouseUp   = @FormMouseUp

Dim Shared As Boolean Down,CanDraw
Dim Shared As Integer Bx,By,Ex,Ey

Dim As HMENU File
File = CreatePopupMenu
AppendMenu Form.MainMenu,MF_POPUP Or MF_STRING,Cint(File),"File"
AppendMenu File,MF_STRING ,100,"Rectangle"
AppendMenu File,MF_STRING,101,"Ellipse"
AppendMenu File,MF_STRING,102,"Button"
AppendMenu File,MF_STRING,103,"Line"
AppendMenu File,MF_SEPARATOR,-1,"-"
AppendMenu File,MF_STRING,104,"Move"
AppendMenu File,MF_STRING,105,"Resize"
AppendMenu File,MF_SEPARATOR,-1,"-"
AppendMenu File,MF_STRING,106,"Exit"
DrawMenuBar Form.Handle

Form.Run

Sub DrawBox(Form As TForm,x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer)
    Dim As HDC Dc
    Dim As HBRUSH B,oldB
    Dc = GetDCEx(Form.Handle,0,DCX_PARENTCLIP Or DCX_CACHE)
    B = GetStockObject(NULL_BRUSH)
    oldB = SelectObject(Dc,B)
    SetROP2 Dc,R2_NOT
    Rectangle Dc,x1,y1,x2,y2
    SelectObject(Dc,oldB)
    ReleaseDC Form.Handle,Dc
End Sub

Sub FormCommand(Sender As TForm,Code As Integer,ID As Integer,FWindow As HWND)
    CheckMenuRadioItem(Sender.MainMenu,100,103,ID,MF_BYCOMMAND)
    Select Case ID
    Case 100
        Shape = Allocate(Sizeof(TShape))
        Shape->Kind = skRectangle
        CanDraw = 1
    Case 101
        Shape = Allocate(Sizeof(TShape))
        Shape->Kind = skEllipse
        CanDraw = 1
    Case 102
        Shape = Allocate(Sizeof(TShape))
        Shape->Kind = skButton
        CanDraw = 1
    Case 103
        Shape = Allocate(Sizeof(TShape))
        Shape->Kind = skLine 
        CanDraw = 1
    End Select
End Sub

Sub FormMouseDown(Sender As TForm,b As Integer,x As Integer,y As Integer,Shift As Integer)
    Bx = x
    By = y
    Ex = x
    Ey = y
    If CanDraw Then 
       Down = 1
       Sender.MouseCapture = 1
    Else
       Sender.MouseCapture = 0
    End If
End Sub

Sub FormMouseMove(Sender As TForm,x As Integer,y As Integer,Shift As Integer)
    If Down Then
        DrawBox Form,Bx,By,Ex,Ey
        DrawBox Form,Bx,By,x,y
    End If
    Ex = x
    Ey = y
End Sub

Sub FormMouseUp(Sender As TForm,b As Integer,x As Integer,y As Integer,Shift As Integer)
    Down = 0
    If CanDraw Then
        CanDraw = 0
        DrawBox Form,Bx,By,Ex,Ey
        Shape->SPoint = Type(Bx,By)
        Shape->EPoint = Type(Ex,Ey)
        Shape->OnMouseDown = @ShapeMouseDown
        Shape->OnMouseMove = @ShapeMouseMove
        Sender.Shapes.Add Shape
        Sender.MouseCapture = 0
    End If 
    CheckMenuRadioItem(Sender.MainMenu,100,103,-1,MF_BYCOMMAND)
    Ex = Bx
    Ey = By
End Sub

Sub ShapeMouseMove(Sender As TShape,x As Integer,y As Integer)
    Form.Text = "Simple Graphic " & "Shape = " & Str(@sender)+" X = " & Str(x) & " Y = " & Str(y)
End Sub

Sub ShapeMouseDown(Sender As TShape,b As Integer,x As Integer,y As Integer)
     MessageBox Form.Handle,"Shape MouseDown "& "Shape = " & Str(@sender)," X = " & Str(x) & " Y = " & Str(y),0
     Sender.BringToFront
End Sub