VFP也可以設計小畫家?

話說VFP的繪圖功能一直是大家公認不夠強的一環
但其實只要良好的設計，VFP還是可在繪圖方面滿足大部分的需求
以下是我去年無聊時寫的，並不很完整，只是給大家一個思考的方向

******************************************
* Green Draw Control 2005/6 VFP9.0
******************************************
myform=CREATEOBJECT('form')
myform.addobject('mydraw','w_drawarea')
myform.mydraw.top=0
myform.mydraw.width=0
myform.mydraw.width=myform.width
myform.mydraw.height=myform.height
*myform.mydraw.anchor=195
myform.mydraw.visible=.T.
myform.show
READ EVENTS
*
DEFINE CLASS w_drawarea AS container
Width = 367
Height = 261
BackColor = RGB(255,255,255)
mcurrx = 0
mcurry = 0
mlinestart = .F.
mlinestartx = 0
mlinestarty = 0
mlineno = 0
*-- 目前的繪圖模式
mtype = "Select"
mselect = 1
Name = "w_drawarea"
ADD OBJECT w_shape1 AS shape WITH ;
Top = 0, ;
Left = 0, ;
Height = 264, ;
Width = 61, ;
BackStyle = 1, ;
Name = "W_shape1"
ADD OBJECT position AS label WITH ;
Alignment = 2, ;
Caption = "", ;
Height = 26, ;
Left = 3, ;
Top = 3, ;
Width = 54, ;
Name = "Position"
ADD OBJECT w_optiongroup1 AS optiongroup WITH ;
AutoSize = .T., ;
ButtonCount = 4, ;
BackStyle = 0, ;
BorderStyle = 0, ;
Height = 84, ;
Left = 0, ;
Top = 22, ;
Width = 62, ;
Name = "W_optiongroup1", ;
Option1.Caption = "Select", ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Style = 1, ;
Option1.Top = 5, ;
Option1.Width = 52, ;
Option1.AutoSize = .F., ;
Option1.Name = "Option1", ;
Option2.Caption = "Clear", ;
Option2.Height = 17, ;
Option2.Left = 5, ;
Option2.Style = 1, ;
Option2.Top = 24, ;
Option2.Width = 52, ;
Option2.AutoSize = .F., ;
Option2.Name = "Option2", ;
Option3.Caption = "Line", ;
Option3.Height = 17, ;
Option3.Left = 5, ;
Option3.Style = 1, ;
Option3.Top = 43, ;
Option3.Width = 52, ;
Option3.AutoSize = .F., ;
Option3.Name = "Option3", ;
Option4.Caption = "CLine", ;
Option4.Height = 17, ;
Option4.Left = 5, ;
Option4.Style = 1, ;
Option4.Top = 62, ;
Option4.Width = 52, ;
Option4.AutoSize = .F., ;
Option4.Name = "Option4"
ADD OBJECT w_listbox1 AS listbox WITH ;
Height = 132, ;
Left = 2, ;
Top = 106, ;
Width = 55, ;
Name = "W_listbox1"
PROCEDURE drawline
Lparameters psx,psy,pex,pey,plinename
*
This.AddObject(plinename,'w_drawline')
this.MousePointer=2 &&
*定義線的樣式及座標
Do Case
Case psx<=pex And psy<=pey && top=psy,left=psx
This.&cName..LineSlant=""
This.&cName..Top=psy
This.&cName..Left=psx
Case psx>pex And psy
This.&cName..LineSlant="/"
This.&cName..Top=psy
This.&cName..Left=pex
Case psx>pex And psy>pey && top=pey,left=pex
This.&cName..LineSlant=""
* This.&cName..Top=psy
* This.&cName..Left=psx
This.&cName..Top=pey
This.&cName..Left=pex
Case psx
pey && / top=pey,left=psx
This.&cName..LineSlant="/"
This.&cName..Top=pey
This.&cName..Left=psx
OTHERWISE
Endcase
If !"tmp"$plinename
This.drawobj.Add(This.&cName)
this.w_listbox1.AddItem(This.&cName..name)
ELSE
This.&cName..BorderStyle=3 &&dot
Endif
This.&cName..Width=Abs(pex-psx)+1 &&寬
This.&cName..Height=Abs(pey-psy)+1 &&高
This.&cName..Visible=.T.
ENDPROC
PROCEDURE RightClick
PRIVATE p_Type
p_Type=This.mtype
Do Case
Case p_Type="Select"
*選擇模式
Case p_Type="Line" OR p_Type="ContinusLine"
*放棄畫線模式
If This.mlinestart==.T. && 已有設第一點
This.mlinestart=.F.
If Type("this.Linetmp")=="O"
This.Linetmp.Visible=.F.
This.RemoveObject("Linetmp")
Endif
Endif
Endcase
ENDPROC
PROCEDURE MouseMove
Lparameters nButton, nShift, nXCoord, nYCoord
Private p_Type
This.mCurrX=nXCoord-This.Left
This.mCurrY=nYCoord-This.Top
this.position.Caption=Str(This.mCurrX,3,0)+","+Str(This.mCurrY,3,0)
p_Type=This.mtype
Do Case
Case p_Type="Select"
*選擇模式
Case p_Type="Line" OR p_Type="ContinusLine"
*畫線模式
If This.mlinestart==.T. && 已有設第一點
*畫線
sx=This.mlinestartx
sy=This.mlinestarty
ex=This.mcurrx
ey=This.mcurry
*
*This.mlineno=This.mlineno+1
*
cName="Linetmp"
If Type("this.Linetmp")=="O"
This.Linetmp.Visible=.F.
This.RemoveObject("Linetmp")
Endif
This.DRAWLINE(sx,sy,ex,ey,cName)
ENDIF
Endcase
ENDPROC
PROCEDURE Click
Private sx,sy,ex,ey,p_type
p_type=This.mtype
Do Case
Case p_Type="Select"
*選擇模式
Case p_Type="Line"
*畫線模式
If This.mlinestart==.F.
This.mlinestartx=This.mcurrx
This.mlinestarty=This.mcurry
This.mlinestart=.T.
Else
*畫線
sx=This.mlinestartx
sy=This.mlinestarty
ex=This.mcurrx
ey=This.mcurry
*
This.mlineno=This.mlineno+1
*
cName="Line"+Alltrim(Str(This.mlineno))
This.DRAWLINE(sx,sy,ex,ey,cName)
If Type("this.Linetmp")=="O"
This.RemoveObject("Linetmp")
Endif
This.mlinestart=.F.
ENDIF
Case p_Type="ContinusLine"
*畫線模式
If This.mlinestart==.F.
This.mlinestartx=This.mcurrx
This.mlinestarty=This.mcurry
This.mlinestart=.T.
Else
*畫線
sx=This.mlinestartx
sy=This.mlinestarty
ex=This.mcurrx
ey=This.mcurry
*
This.mlineno=This.mlineno+1
*
cName="Line"+Alltrim(Str(This.mlineno))
This.DRAWLINE(sx,sy,ex,ey,cName)
If Type("this.Linetmp")=="O"
This.RemoveObject("Linetmp")
ENDIF
This.mlinestartx=ex
This.mlinestarty=ey
Endif
Endcase
ENDPROC
PROCEDURE Init
this.AddObject("drawobj","Collection")
ENDPROC
PROCEDURE w_shape1.Init
this.Height=this.Parent.Height
ENDPROC
PROCEDURE w_optiongroup1.Click
If Type("this.parent.Linetmp")=="O"
This.Parent.Linetmp.Visible=.F.
This.Parent.RemoveObject("Linetmp")
This.Parent.mlinestart=.F.
Endif
*
Do Case
Case This.Value=1 && Select
This.Parent.mtype="Select"
this.Parent.MousePointer=1
Case This.Value=2 && Clear
If(Type("this.parent.drawobj")=="O")
Do While this.parent.drawobj.Count>0
objname=this.parent.drawobj[1].Name
this.parent.RemoveObject(objname)
Enddo
this.parent.visible=.F.
this.parent.visible=.T.
ENDIF
Case This.Value=3 && Line
This.Parent.mtype="Line"
this.Parent.MousePointer= 2
Case This.Value=4 && ContinusLine
This.Parent.mtype="ContinusLine"
this.Parent.MousePointer= 2
ENDCASE
*
If This.Value<>2
This.Parent.mselect=This.Value
Else
This.Value=This.Parent.mselect
Endif
ENDPROC
PROCEDURE w_listbox1.Click
PRIVATE mselecobj
IF !EMPTY(this.value)
mselecobj="this.parent."+this.value
IF TYPE(mselecobj)=="O"
&mselecobj..BorderWidth=&mselecobj..BorderWidth+1
ENDIF
ENDIF
ENDPROC
ENDDEFINE
*
*
DEFINE CLASS w_drawline AS line
Height = 17
Width = 100
*-- 判斷是否被選擇了
mselected = .F.
Name = "w_drawline"
PROCEDURE chk_in
Lparameters p_x,p_y
PRIVATE ret,sx,sy,ex,ey
ret=.F.
*p_x,p_y 目前游標所在的位置,依線的slant來檢查是否進入實際線的範圍內
If This.LineSlant==""
Else
*"/"
Endif
RETURN ret
ENDPROC
PROCEDURE MouseLeave
LPARAMETERS nButton, nShift, nXCoord, nYCoord
Private p_type
If Type("This.Parent")=="O"
p_type=This.Parent.mType
Do Case
Case p_type="Line"
Case p_type="Select"
*進入線的範圍內時,將線寬加大,否則恢復原狀
this.BorderWidth=this.BorderWidth-1
ENDCASE
RAISEEVENT(THIS.Parent,"MouseMove",nButton,nShift,nXCoord,nYCoord)
Endif
ENDPROC
PROCEDURE MouseEnter
LPARAMETERS nButton, nShift, nXCoord, nYCoord
Private p_type
If Type("This.Parent")=="O"
p_type=This.Parent.mType
Do Case
Case p_type="CLine"
this.MousePointer= 2
Case p_type="Line"
this.MousePointer= 2
Case p_type="Select"
this.MousePointer= 0
*進入線的範圍內時,將線寬加大,否則恢復原狀
this.BorderWidth=this.BorderWidth+1
ENDCASE
RAISEEVENT(THIS.Parent,"MouseMove",nButton,nShift,nXCoord,nYCoord)
Endif
ENDPROC
PROCEDURE RightClick
RAISEEVENT(THIS.Parent,"RightClick")
ENDPROC
PROCEDURE Click
RAISEEVENT(THIS.Parent,"Click")
ENDPROC
PROCEDURE MouseMove
Lparameters nButton, nShift, nXCoord, nYCoord
Private p_type
If Type("This.Parent")=="O"
p_type=This.Parent.mType
Do Case
Case p_type="Line"
Case p_type="Select"
ENDCASE
RAISEEVENT(THIS.Parent,"MouseMove",nButton,nShift,nXCoord,nYCoord)
Endif
*
ENDPROC
ENDDEFINE
*

發表於 2006/05/30 10:34 PM