diff --git a/.gitattributes b/.gitattributes index b887c51d10..5c510c872d 100644 --- a/.gitattributes +++ b/.gitattributes @@ -904,6 +904,7 @@ lcl/extctrls.pp svneol=native#text/pascal lcl/extdlgs.lrs svneol=native#text/pascal lcl/extdlgs.pas svneol=native#text/pascal lcl/extendedstrings.pas svneol=native#text/pascal +lcl/extgraphics.pas svneol=native#text/pascal lcl/filectrl.pp svneol=native#text/pascal lcl/forms.pp svneol=native#text/pascal lcl/fpcadds.pas svneol=native#text/pascal diff --git a/lcl/alllclunits.pp b/lcl/alllclunits.pp index 09eff85b4b..698bee4b9b 100644 --- a/lcl/alllclunits.pp +++ b/lcl/alllclunits.pp @@ -43,7 +43,7 @@ uses Comctrls, Graphics, StdCtrls, Arrow, Controls, ImgList, Menus, Toolwin, Dialogs, Messages, Clistbox, ActnList, Grids, MaskEdit, Printers, PostScriptPrinter, CheckLst, PairSplitter, ExtDlgs, - DBCtrls, DBGrids, EditBtn, + DBCtrls, DBGrids, EditBtn, ExtGraphics, // widgetset skeleton WSActnList, WSArrow, WSButtons, WSCalendar, WSCheckLst, WSCListBox, WSComCtrls, WSControls, @@ -60,6 +60,9 @@ end. { ============================================================================= $Log$ + Revision 1.13 2004/05/01 23:24:19 mattias + fixed range check error and added extgraphics.pas + Revision 1.12 2004/04/29 18:08:17 mattias fixed 1.0.10 compilation diff --git a/lcl/extgraphics.pas b/lcl/extgraphics.pas new file mode 100644 index 0000000000..cb1b9ae1ac --- /dev/null +++ b/lcl/extgraphics.pas @@ -0,0 +1,255 @@ +{ $Id$ } +{ + /*************************************************************************** + extgraphics.pas + --------------- + + ***************************************************************************/ + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.LCL, included in this distribution, * + * for details about the copyright. * + * * + * This program is distributed in the hope that it will be useful, * + * but WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * + * * + ***************************************************************************** +} +unit ExtGraphics; + +{$mode objfpc}{$H+} + +interface + +uses Classes, Graphics; + +type + TArrowDirection = (atUp, atDown, atLeft, atRight); + +procedure PaintDiamond(Canvas: TCanvas; const PaintRect: TRect); +procedure PaintCross(Canvas: TCanvas; XLeft,YUp,XRight,YLow, + CrossX1,CrossX2,CrossY1,CrossY2:integer); +procedure PaintPlus(Canvas: TCanvas; const PaintRect: TRect); +procedure PaintTriangle(Canvas: TCanvas; const PaintRect: TRect; + AArrowType: TArrowDirection); +procedure PaintBoldArrow(Canvas: TCanvas; const PaintRect: TRect; + AArrowType: TArrowDirection); +procedure PaintChevronArrow(Canvas: TCanvas; const PaintRect: TRect; + AArrowType: TArrowDirection); +procedure PaintVArrow(Canvas: TCanvas; const PaintRect : TRect; + AArrowType: TArrowDirection); + +implementation + +procedure PaintDiamond(Canvas: TCanvas; const PaintRect: TRect); +var + P: array[0..3] of TPoint; +begin + with PaintRect do begin + P[0].x:=Left; P[0].y:=Top + (Bottom - Top) div 2; + P[1].x:=Left+ (Right - Left) div 2; P[1].y:=Bottom; + P[2].x:=Right; P[2].y:= P[0].y; + P[3].x:=P[1].x; P[3].y:=Top; + Canvas.Polygon(P); + end; +end; + +procedure PaintCross(Canvas: TCanvas; XLeft,YUp,XRight,YLow, + CrossX1,CrossX2,CrossY1,CrossY2:integer); +var P:array[0..12] of TPoint; +begin + P[ 0].x:=XLeft; P[ 0].y:=CrossY1; + P[ 1].x:=CrossX1; P[ 1].y:=P[0].y; + P[ 2].x:=P[ 1].x; P[ 2].y:= YUp; + P[ 3].x:=CrossX2; P[ 3].y:=P[2].y; + P[ 4].x:=P[ 3].x; P[ 4].y:=CrossY1; + P[ 5].x:=XRight; P[ 5].y:=P[4].y; + P[ 6].x:=P[ 5].x; P[ 6].y:=CrossY2; + P[ 7].x:=CrossX2; P[ 7].y:=P[6].y; + P[ 8].x:=P[ 7].x; P[ 8].y:=YLow; + P[ 9].x:=CrossX1; P[ 9].y:=P[8].y; + P[10].x:=P[ 9].x; P[10].y:=CrossY2; + P[11].x:=XLeft; P[11].y:=P[10].y; + P[12].x:=P[11].x; P[12].y:=CrossY1; + Canvas.Polygon(P); +end; + + +procedure PaintPlus(Canvas: TCanvas; const PaintRect: TRect); +var CrossX1,CrossX2,CrossY1,CrossY2:integer; +begin + with PaintRect do begin + CrossX1:=Left+(Right-Left) div 3 ; + CrossX2:=Left+(Right-Left) * 2 div 3; + CrossY1:=Top+(Bottom-Top) div 3 ; + CrossY2:=Top+(Bottom-Top) * 2 div 3 ; + PaintCross(Canvas,Left,Top,Right,Bottom,CrossX1,CrossX2,CrossY1,CrossY2); + end; +end; + +Procedure PaintTriangle(Canvas: TCanvas; const PaintRect: TRect; + AArrowType :TArrowDirection); +var P:array[0..2] of TPoint; +begin + Case AArrowType of + AtUp: with PaintRect do begin + P[0].x:=Left; P[0].y:=Bottom; + P[1].x:=Left+ (Right - Left) div 2; P[1].y:=Top; + P[2].x:=Right; P[2].y:= P[0].y; + end; + AtDown: with PaintRect do begin + P[0].x:=Left; P[0].y:=Top; + P[1].x:=Left+ (Right - Left) div 2; P[1].y:=Bottom; + P[2].x:=Right; P[2].y:= P[0].y; + end; + AtRight: with PaintRect do begin + P[0].x:=Left; P[0].y:=Top; + P[1].x:=Right; P[1].y:=Top+(Bottom-Top) div 2; + P[2].x:=P[0].x; P[2].y:= Bottom; + end; + AtLeft: with PaintRect do begin + P[0].x:=Right; P[0].y:=Top; + P[1].x:=Left; P[1].y:=Top+(Bottom-Top) div 2; + P[2].x:=P[0].x; P[2].y:= Bottom; + end; + end; + Canvas.Polygon(P); +end; + +Procedure PaintBoldArrow(Canvas: TCanvas; const PaintRect: TRect; + AArrowType :TArrowDirection); +var P:array[0..6] of TPoint; +begin + with PaintRect do begin + Case AArrowType of + AtUp: begin + P[2].y:= Top; + P[5].y:= Bottom; + end; + AtDown: begin + P[2].y:= Bottom; + P[5].y:= Top; + end; + AtRight: begin + P[0].x:= Left; + P[3].x:= Right; + end; + AtLeft: begin + P[0].x:= Right; + P[3].x:= Left; + end; + end; + Case AArrowType of + AtUp, AtDown: begin + P[0].x:=Left + (Right - Left) div 4; P[0].y:=Top + (Bottom - Top) div 2; + P[1].x:=Left; P[1].y:=P[0].y; + P[2].x:=Left + (Right - Left) div 2; + P[3].x:=Right; P[3].y:=P[0].y; + P[4].x:=Right - (Right - Left) div 4; P[4].y:= P[0].y; + P[5].x:=P[4].x; + P[6].x:=P[0].x; P[6].y:=P[5].y; + end; + AtRight, AtLeft: begin + P[0].y:=Top+(Bottom-Top) div 4; + P[1].x:=Left + (Right - Left) div 2; P[1].y:=P[0].y; + P[2].x:=P[1].x; P[2].y:= Top; + P[3].y:=Top + (Bottom - Top) div 2; + P[4].x:=P[1].x; P[4].y:= Bottom; + P[5].x:=P[1].x; P[5].y:=Bottom-(Bottom-Top) div 4; + P[6].x:=P[0].x; P[6].y:=P[5].y; + end; + end; + Canvas.Polygon(P); + end; +end; + +Procedure PaintChevronArrow(Canvas: TCanvas; const PaintRect: TRect; + AArrowType: TArrowDirection); +var P: array[0..6] of TPoint; +begin + with PaintRect do begin + P[0].y:=Top; + Case AArrowType of + AtUp: begin + P[2].y:= Top; + P[5].y:= Bottom; + end; + AtDown: begin + P[2].y:= Bottom; + P[5].y:= Top; + end; + AtRight: begin + P[0].x:= Left; + P[1].x:= Right-(Right - Left) div 3; + P[2].x:= Right; + P[5].x:= Left + (Right - Left) div 3; + end; + AtLeft: begin + P[0].x:= Left + (Right - Left) div 3; + P[1].x:= Right; + P[2].x:= Right-(Right - Left) div 3; + P[5].x:= Left; + end; + end; + Case AArrowType of + AtUp, AtDown: begin + P[0].x:=Left + (Right - Left) div 4; P[0].y:=Top + (Bottom - Top) div 2; + P[1].x:=Left; P[1].y:=P[0].y; + P[2].x:=Left + (Right - Left) div 2; + P[3].x:=Right; P[3].y:=P[0].y; + P[4].x:=Right - (Right - Left) div 4; P[4].y:= P[0].y; + P[5].x:=P[4].x; + P[6].x:=P[0].x; P[6].y:=P[5].y; + end; + AtRight, AtLeft: begin + P[1].y:=P[0].y; + P[2].y:= Bottom-(Bottom-Top) div 2; + P[3].x:=P[1].x; + P[3].y:=Bottom; + P[4].x:=P[0].x; P[4].y:= P[3].y; + P[5].y:=P[2].y; + end; + end; + Canvas.Polygon(P); + end; +end; + + +Procedure PaintVArrow(Canvas: TCanvas; const PaintRect : TRect; + AArrowType :TArrowDirection); +var P:array[0..3] of TPoint; +begin + with PaintRect do begin + P[3].x:=Left+ (Right - Left) div 2; P[3].y:=Top+(Bottom-Top) div 2; + Case AArrowType of + AtUp: begin + P[0].x:=Left; P[0].y:=Bottom; + P[1].x:=Left+ (Right - Left) div 2; P[1].y:=Top; + P[2].x:=Right; P[2].y:= P[0].y; + end; + AtDown:begin + P[0].x:=Left; P[0].y:=Top; + P[1].x:=Left+ (Right - Left) div 2; P[1].y:=Bottom; + P[2].x:=Right; P[2].y:= P[0].y; + end; + AtRight: begin + P[0].x:=Left; P[0].y:=Top; + P[1].x:=Right; P[1].y:=Top+(Bottom-Top) div 2; + P[2].x:=P[0].x; P[2].y:= Bottom; + end; + AtLeft: begin + P[0].x:=Right; P[0].y:=Top; + P[1].x:=Left; P[1].y:=Top+(Bottom-Top) div 2; + P[2].x:=P[0].x; P[2].y:= Bottom; + end; + end; + end; + Canvas.Polygon(P); +end; + + +end. diff --git a/lcl/widgetset/wslclclasses.pp b/lcl/widgetset/wslclclasses.pp index 74d03c10da..0c36de9ab9 100644 --- a/lcl/widgetset/wslclclasses.pp +++ b/lcl/widgetset/wslclclasses.pp @@ -124,16 +124,18 @@ begin end; type - TMethodNameTable = packed record - Count: DWord; - Entries: packed array[0..0] of packed record + TMethodNameTableEntry = packed record Name: PShortstring; Addr: Pointer; end; + + TMethodNameTable = packed record + Count: DWord; + Entries: packed array[0..9999999] of TMethodNameTableEntry; end; PMethodNameTable = ^TMethodNameTable; - TPointerArray = packed array[0..0] of Pointer; + TPointerArray = packed array[0..9999999] of Pointer; PPointerArray = ^TPointerArray; procedure RegisterWSComponent(const AComponent: TComponentClass;