Dans mes archive j'ai retrouver un code de Microdevweb qui permet de dessiner un rectangle et de le deplacer sur le canvas
Code : Tout sélectionner
;**********************************************************************************************************
; Author : MicordevWeb
; Name : EasyDraw
; Date : 2015/10/17
; Version: B 0.1
; Pb: 5.40 lst
;**********************************************************************************************************
EnableExplicit
UseSQLiteDatabase()
Enumeration
#Font
#MainForm
#MainMenu
#New
#Open
#Save
#SaveAs
#Close
#Exit
#PropertieForm
#SpW
#SpH
#BtSubmit
#BtChancel
#ScrollArea
#Canvas
#NewBox
#NewCircle
EndEnumeration
Enumeration
#ModeSelect
#MdNewBox
#MdNewCircle
EndEnumeration
Enumeration
#ObBox
#ObCircle
EndEnumeration
Structure Pos
X.d
Y.d
W.d
H.d
EndStructure
Global myPos.Pos,myOldPos.Pos,UL.Pos,UM.Pos,UR.Pos,
DL.Pos,DM.Pos,DR.Pos,LM.Pos,RM.Pos,newPos.Pos,
gDb,gMotherForm,gModeNew.b,gExt$,gDrawW,gDrawH,
gModeDraw=#ModeSelect,gMouseX,gMouseY,gClicOn.b=#False,
gImgTmp,gActiOn.b,gId=-1,gObj,gCurrentHandle$,gSelected
LoadFont(#Font,"Arial",12,#PB_Font_HighQuality)
Declare OpenDrawPropertie()
Declare CloseForm()
Declare ManageCanvas()
Declare DrawCanvas()
Procedure DbQuey(query$)
If DatabaseQuery(gDb,query$)=0
MessageRequester("DbQuey Error",DatabaseError())
ProcedureReturn #False
EndIf
ProcedureReturn #True
EndProcedure
Procedure DbUpdate(query$)
If DatabaseUpdate(gDb,query$)=0
MessageRequester("DbUpdate Error",DatabaseError())
ProcedureReturn #False
EndIf
ProcedureReturn #True
EndProcedure
Macro mAddTable(Table)
query$= "CREATE TABLE "+Table+"("
For N=0 To ArraySize(Column$(),1)
If N>0
query$+","
EndIf
query$+Column$(N,0)+" "+Column$(N,1)
Next
query$+")"
If Not DbUpdate(query$):End:EndIf
EndMacro
Procedure BuildMemorisDb()
gDb=OpenDatabase(#PB_Any,":memory:","","")
If gDb=0
MessageRequester("BuildMemorisDb Error","Can not open DataBase")
ProcedureReturn #False
EndIf
Protected query$,N
Dim Column$(7,1)
Column$(0,0)="id":Column$(1,0)="x":Column$(2,0)="y":Column$(3,0)="w":Column$(4,0)="h"
Column$(5,0)="fgcolor":Column$(6,0)="bgcolor":Column$(7,0)="filled"
Column$(0,1)="INTEGER PRIMARY KEY"
For N=1 To 7 :Column$(N,1)="INTEGER":Next
mAddTable("box")
mAddTable("circle")
EndProcedure
Procedure NewDraw()
gModeNew=#True
OpenDrawPropertie()
SetActiveGadget(#spW)
EndProcedure
Procedure OpenDraw()
EndProcedure
Procedure SaveDraw()
EndProcedure
Procedure SaveAsDraw()
EndProcedure
Procedure CloseDraw()
EndProcedure
Procedure Exit()
CloseDatabase(gDb)
End
EndProcedure
Procedure EventResize()
ManageCanvas()
EndProcedure
Procedure HoverToForm()
Protected query$
query$="SELECT * FROM box WHERE (X<="+Str(gMouseX)+" AND "+
"(X+W)>="+Str(gMouseX)+")"+
"AND (Y<="+Str(gMouseY)+" AND (Y+H)>="+Str(gMouseY)+")"
If Not DbQuey(query$):End:EndIf
gId=-1
If FirstDatabaseRow(gDb)
gId=GetDatabaseLong(gDb,0)
gObj=#ObBox
ProcedureReturn #True
EndIf
ProcedureReturn #False
EndProcedure
Procedure PreDrawBox()
gActiOn=#True
With myPos
\W=gMouseX-\X
\H=gMouseY-\Y
StartVectorDrawing(CanvasVectorOutput(#Canvas))
DrawVectorImage(ImageID(gImgTmp))
AddPathBox(\X,\Y,\W,\H)
VectorSourceColor(RGBA(211,211,211,255))
DotPath(2,4)
StopVectorDrawing()
EndWith
EndProcedure
Procedure AddBox()
Protected query$
query$="INSERT INTO box (x,y,w,h,fgcolor,bgcolor) VALUES ("
With myPos
query$+Str(\X)+","+Str(\Y)+","+Str(\W)+","+Str(\H)+","+
Str(RGBA(0,0,0,255))+","+Str(RGBA(0,0,0,255))+")"
If Not DbUpdate(query$) :End:EndIf
EndWith
gModeDraw=#ModeSelect
gActiOn=#False
DrawCanvas()
EndProcedure
Procedure DrawCanvas()
Protected query$
StartVectorDrawing(ImageVectorOutput(gImgTmp))
; Efface le dessin
AddPathBox(0,0,ImageWidth(gImgTmp),ImageHeight(gImgTmp))
VectorSourceColor(RGBA(255,255,255,255))
FillVectorOutput()
;{ Les box
query$="SELECT * FROM box"
If Not DbQuey(query$):End:EndIf
While NextDatabaseRow(gDb)
AddPathBox(GetDatabaseLong(gDb,1),GetDatabaseLong(gDb,2),GetDatabaseLong(gDb,3),GetDatabaseLong(gDb,4))
VectorSourceColor(GetDatabaseLong(gDb,5))
StrokePath(2)
Wend
FinishDatabaseQuery(gDb)
;}
StopVectorDrawing()
StartVectorDrawing(CanvasVectorOutput(#Canvas))
DrawVectorImage(ImageID(gImgTmp))
StopVectorDrawing()
EndProcedure
Procedure PreDrawEdit()
Protected X,Y,W,H,DepX,DepY
DepX=gMouseX-myPos\X
DepY=gMouseY-myPos\Y
Select gObj
Case #ObBox
gActiOn=#True
With myOldPos
Select gCurrentHandle$
Case ""
X=\X+DepX
Y=\Y+DepY
W=\W
H=\H
Case "UL"
X=\X+DepX
Y=\Y+DepY
W=\W-DepX
H=\H-DepY
Case "UR"
X=\X
Y=\Y+DepY
W=\W+DepX
H=\H-DepY
Case "UM"
X=\X
Y=\Y+DepY
W=\W
H=\H-DepY
Case "DL"
X=\X+DepX
Y=\Y
W=\W-DepX
H=\H+DepY
Case "DR"
X=\X
Y=\Y
W=\W+DepX
H=\H+DepY
Case "DM"
X=\X
Y=\Y
W=\W
H=\H+DepY
Case "LM"
X=\X+DepX
Y=\Y
W=\W-DepX
H=\H
Case "RM"
X=\X
Y=\Y
W=\W+DepX
H=\H
EndSelect
EndWith
EndSelect
StartVectorDrawing(CanvasVectorOutput(#Canvas))
DrawVectorImage(ImageID(gImgTmp))
AddPathBox(X,Y,W,H)
With newPos
\X=X
\Y=Y
\W=W
\H=H
EndWith
VectorSourceColor(RGBA(211,211,211,255))
DotPath(2,4)
StopVectorDrawing()
EndProcedure
Procedure DrawHandle()
Protected X,Y,W=8
StartVectorDrawing(ImageVectorOutput(gImgTmp))
With myOldPos
Select gObj
Case #ObBox
; Poignée Haut gauche
X=\X-(W/2)
Y=\Y-(W/2)
AddPathBox(X,Y,W,W)
UL\X=X
UL\Y=Y
UL\W=W
; Poignée Haut droite
X=(\X+\W)-(W/2)
Y=\Y-(W/2)
AddPathBox(X,Y,W,W)
UR\X=X
UR\Y=Y
UR\W=W
; Poignée bas gauche
X=\X-(W/2)
Y=(\Y+\H)-(W/2)
AddPathBox(X,Y,W,W)
DL\X=X
DL\Y=Y
DL\W=W
; Poignée Bas droite
X=(\X+\W)-(W/2)
Y=(\Y+\H)-(W/2)
AddPathBox(X,Y,W,W)
DR\X=X
DR\Y=Y
DR\W=W
; Poignée milieu gauche
X=\X-(W/2)
Y=(\Y+(\H/2))-(W/2)
AddPathBox(X,Y,W,W)
LM\X=X
LM\Y=Y
LM\W=W
; Poignée Milieu droite
X=(\X+\W)-(W/2)
Y=(\Y+(\H/2))-(W/2)
AddPathBox(X,Y,W,W)
RM\X=X
RM\Y=Y
RM\W=W
; Poignée Haut Milieu
X=(\X+(\W/2))-(W/2)
Y=\Y-(W/2)
AddPathBox(X,Y,W,W)
UM\X=X
UM\Y=Y
UM\W=W
; Poignée bas milieu
X=(\X+(\W/2))-(W/2)
Y=(\Y+\H)-(W/2)
AddPathBox(X,Y,W,W)
DM\X=X
DM\Y=Y
DM\W=W
VectorSourceColor(RGBA(105,105,105,255))
FillPath()
EndSelect
EndWith
StopVectorDrawing()
StartVectorDrawing(CanvasVectorOutput(#Canvas))
DrawVectorImage(ImageID(gImgTmp))
StopVectorDrawing()
EndProcedure
Procedure HoverHandle()
With UL
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="UL"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_LeftUpRightDown)
ProcedureReturn #True
EndIf
EndWith
With UM
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="UM"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_UpDown)
ProcedureReturn #True
EndIf
EndWith
With UR
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="UR"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_LeftDownRightUp)
ProcedureReturn #True
EndIf
EndWith
With DL
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="DL"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_LeftDownRightUp)
ProcedureReturn #True
EndIf
EndWith
With DM
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="DM"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_UpDown)
ProcedureReturn #True
EndIf
EndWith
With DR
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="DR"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_LeftUpRightDown)
ProcedureReturn #True
EndIf
EndWith
With LM
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="LM"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_LeftRight)
ProcedureReturn #True
EndIf
EndWith
With RM
If (gMouseX>=\X And gMouseX<=(\X+\W)) And (gMouseY>=\Y And gMouseY<=(\Y+\W))
gCurrentHandle$="RM"
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_LeftRight)
ProcedureReturn #True
EndIf
EndWith
gCurrentHandle$=""
ProcedureReturn #False
EndProcedure
Procedure ChangePosition()
Protected query$
With newPos
Select gObj
Case #ObBox
query$="UPDATE box SET "+
"x="+Str(\X)+",y="+Str(\Y)+",w="+Str(\W)+",h="+Str(\H)
myOldPos\X=\X
myOldPos\Y=\Y
myOldPos\W=\W
myOldPos\H=\H
EndSelect
EndWith
If Not DbUpdate(query$):End:EndIf
DrawCanvas()
DrawHandle()
EndProcedure
Procedure EventCanvas()
Select EventType()
Case #PB_EventType_MouseMove
gMouseX=GetGadgetAttribute(#Canvas,#PB_Canvas_MouseX)
gMouseY=GetGadgetAttribute(#Canvas,#PB_Canvas_MouseY)
Select gModeDraw
Case #MdNewBox,#MdNewCircle
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_Cross)
If gClicOn
PreDrawBox()
EndIf
Case #ModeSelect
If gId<>-1 And gClicOn
PreDrawEdit()
EndIf
If Not gClicOn
If HoverHandle()
ProcedureReturn
EndIf
If HoverToForm()
If gSelected
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_Arrows)
Else
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_Hand)
EndIf
ProcedureReturn
EndIf
SetGadgetAttribute(#Canvas,#PB_Canvas_Cursor,#PB_Cursor_Default)
EndIf
EndSelect
Case #PB_EventType_LeftButtonDown
If Not gClicOn
myPos\X=gMouseX
myPos\Y=gMouseY
If gId<>-1
If gSelected=#True
gActiOn=#True
EndIf
Select gObj
Case #ObBox
myOldPos\X=GetDatabaseLong(gDb,1)
myOldPos\Y=GetDatabaseLong(gDb,2)
myOldPos\W=GetDatabaseLong(gDb,3)
myOldPos\H=GetDatabaseLong(gDb,4)
DrawHandle()
gSelected=#True
EndSelect
Else
gSelected=#False
DrawCanvas()
EndIf
EndIf
gClicOn=#True
Case #PB_EventType_LeftButtonUp
If gActiOn
Select gModeDraw
Case #MdNewBox
AddBox()
Case #ModeSelect
ChangePosition()
EndSelect
EndIf
gClicOn=#False
EndSelect
EndProcedure
Procedure ManageCanvas()
UseGadgetList(WindowID(#MainForm))
If gDrawW>WindowWidth(#MainForm) Or gDrawH>(WindowHeight(#MainForm)-MenuHeight())
If IsGadget(#ScrollArea)=0
ScrollAreaGadget(#ScrollArea,0,0,WindowWidth(#MainForm),(WindowHeight(#MainForm)-MenuHeight()),
gDrawW,gDrawH,10)
Else
ResizeGadget(#ScrollArea,#PB_Ignore,#PB_Ignore,WindowWidth(#MainForm),(WindowHeight(#MainForm)-MenuHeight()))
SetGadgetAttribute(#ScrollArea,#PB_ScrollArea_InnerWidth,gDrawW)
SetGadgetAttribute(#ScrollArea,#PB_ScrollArea_InnerHeight,gDrawH)
OpenGadgetList(#ScrollArea)
EndIf
Else
If IsGadget(#ScrollArea)<>0
FreeGadget(#ScrollArea)
EndIf
EndIf
If IsGadget(#Canvas)=0
CanvasGadget(#Canvas,0,0,gDrawW,gDrawH,#PB_Canvas_Keyboard)
gImgTmp=CreateImage(#PB_Any,gDrawW,gDrawH)
StartDrawing(ImageOutput(gImgTmp))
Box(0,0,ImageWidth(gImgTmp),ImageHeight(gImgTmp),$FFFFFF)
StopDrawing()
BindGadgetEvent(#Canvas,@EventCanvas())
Else
ResizeGadget(#Canvas,#PB_Ignore,#PB_Ignore,gDrawW,gDrawH)
ResizeImage(gImgTmp,gDrawW,gDrawH)
EndIf
If IsGadget(#ScrollArea)<>0
CloseGadgetList()
EndIf
EndProcedure
Procedure SavePropertie()
gDrawW=GetGadgetState(#spW)
gDrawH=GetGadgetState(#spH)
CloseForm()
ManageCanvas()
EndProcedure
Procedure CloseForm()
If gMotherForm<>-1
DisableWindow(gMotherForm,#False)
EndIf
CloseWindow(EventWindow())
EndProcedure
Procedure OpenDrawPropertie()
Protected title$
Protected M=10,X=M,Y=M,W=180,H=30
Protected WF=(W*1)+(M*2),HF=(H*5)+(M*4)
Protected Flag=#PB_Window_ScreenCentered|#PB_Window_SystemMenu
Protected tmp
gExt$=" pxl"
If gModeNew
title$="Nouveau document"
Else
title$="Propriété du document"
EndIf
gMotherForm=#MainForm
DisableWindow(gMotherForm,#True)
OpenWindow(#PropertieForm,0,0,WF,HF,title$,Flag,WindowID(#MainForm))
tmp=TextGadget(#PB_Any,X,Y,W,H,"Largeur:")
SetGadgetFont(tmp,FontID(#Font))
Y+H
SpinGadget(#spW,X,Y,W,H,0,2500,#PB_Spin_Numeric)
SetGadgetFont(#spW,FontID(#Font))
Y+H+M
tmp=TextGadget(#PB_Any,X,Y,W,H,"Hauteur:")
SetGadgetFont(tmp,FontID(#Font))
Y+H
SpinGadget(#spH,X,Y,W,H,0,2500,#PB_Spin_Numeric)
SetGadgetFont(#spH,FontID(#Font))
Y+H+M
W=(W/2)-M
ButtonGadget(#BtSubmit,X,Y,W,H,"Valider")
SetGadgetFont(#BtSubmit,FontID(#Font))
BindGadgetEvent(#BtSubmit,@SavePropertie())
X+W+M
ButtonGadget(#BtChancel,X,Y,W,H,"Annuler")
SetGadgetFont(#BtChancel,FontID(#Font))
BindGadgetEvent(#BtChancel,@CloseForm())
BindEvent(#PB_Event_CloseWindow,@CloseForm(),#PropertieForm)
EndProcedure
Procedure NewBox()
gActiOn=#False
gModeDraw=#MdNewBox
EndProcedure
Procedure OpenMainForm()
Protected Flag=#PB_Window_ScreenCentered|#PB_Window_SystemMenu|#PB_Window_Maximize|#PB_Window_MaximizeGadget
Flag|#PB_Window_MinimizeGadget|#PB_Window_SizeGadget
OpenWindow(#MainForm,0,0,800,600,"Easy Draw",Flag)
CreateMenu(#MainMenu,WindowID(#MainForm))
MenuTitle("Fichier")
MenuItem(#New,"Nouveau "+Chr(9)+"ALT N")
AddKeyboardShortcut(#MainForm,#PB_Shortcut_Alt|#PB_Shortcut_N,#New)
BindMenuEvent(#MainMenu,#New,@NewDraw())
MenuItem(#Open,"Ouvrir "+Chr(9)+"ALT O")
AddKeyboardShortcut(#MainForm,#PB_Shortcut_Alt|#PB_Shortcut_N,#Open)
BindMenuEvent(#MainMenu,#Open,@OpenDraw())
MenuItem(#Save,"Sauver "+Chr(9)+"CTRL S")
AddKeyboardShortcut(#MainForm,#PB_Shortcut_Control|#PB_Shortcut_N,#Save)
BindMenuEvent(#MainMenu,#Save,@SaveDraw())
MenuItem(#SaveAs,"Sauver sous ")
BindMenuEvent(#MainMenu,#SaveAs,@SaveAsDraw())
MenuItem(#Close,"Fermer ")
BindMenuEvent(#MainMenu,#Close,@CloseDraw())
MenuBar()
MenuItem(#Exit,"Quitter ")
BindMenuEvent(#MainMenu,#Exit,@Exit())
MenuTitle("Nouvelle forme")
MenuItem(#NewBox,"Rectangle "+Chr(9)+"ALT B")
AddKeyboardShortcut(#MainForm,#PB_Shortcut_Alt|#PB_Shortcut_B,#NewBox)
BindMenuEvent(#MainMenu,#NewBox,@NewBox())
BindEvent(#PB_Event_CloseWindow,@Exit(),#MainForm)
BindEvent(#PB_Event_SizeWindow,@EventResize(),#MainForm)
EndProcedure
BuildMemorisDb()
OpenMainForm()
gDrawW=WindowWidth(#MainForm)
gDrawH=WindowHeight(#MainForm)-MenuHeight()
ManageCanvas()
Global gEvent
Repeat:gEvent=WaitWindowEvent():ForEver
