Hi Please submit this to mantis as a patch. Could you also create?: procedure Frame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor; Width: Integer);
thanks Diogo On Wed, 07 Feb 2007 15:52:14 +0100 Guadagnini David <[EMAIL PROTECTED]> wrote: > I have note that some useful functions available graphics for Windows > are not present in Lazarus (ok ok are devoted API). I have tried to > rewrite them not using the devoted API. > // ---------------------------------------------- > // Decrease the color working on RGB field > // ---------------------------------------------- > Function DecColor(Colore : TColor; Quantita : Integer) : TColor; > Var > R, G, B : Byte; > > (* ******************************************** *) > (* ******************************************** *) > > Function _Dec(V : Byte) : Byte; > Var > V1 : Integer; > Begin > V1 := V; > V1 := V1 - Quantita; > If V1 < 0 Then V1 := 0; > If V1 > 255 Then V1 := 255; > Result := Byte(V1); > End; > (* ******************************************** *) > (* ******************************************** *) > > Begin > Colore := ColorToRGB(Colore); > R := _Dec(GetRValue(Colore)); > G := _Dec(GetGValue(Colore)); > B := _Dec(GetBValue(Colore)); > Result := RGB(R, G, B); > End; > > // Write a 3D frame exactly how Windows Frame3DFunction but using two > additional params > // > // Clicked : if true invert the frame > // Flat : paint a flat frame > Procedure Frame3D(FCanvas : TCanvas; > Rect : TRect; > FColor : TColor; > Clicked : Boolean; > Flat : Boolean); > Var > C1, C2 : TColor; > begin > If Clicked Then > Begin > C1 := FColor; > C2 := DecColor(FColor, -255); > End > Else > If Flat Then > Begin > C1 := FColor; > C2 := FColor; > End > Else > Begin > C1 := DecColor(FColor, -255); > C2 := FColor; > End; > > FCanvas.Pen.Color := C1; > FCanvas.MoveTo(Rect.Left, Rect.Bottom-1); > FCanvas.LineTo(Rect.Left, Rect.Top); > FCanvas.LineTo(Rect.Right-1, Rect.Top); > > FCanvas.Pen.Color := C2; > FCanvas.LineTo(Rect.Right-1, Rect.Bottom-1); > FCanvas.LineTo(Rect.Left, Rect.Bottom-1); > end; > > type > TGradientDirection = (gdVertical, gdHorizontal); // used in > function GradientFillCanvas > > // Fill a rectangle with gradient color how the Delphi function > GradientFillCanvas > Procedure GradientFillCanvas(ACanvas : TCanvas; > ACStart : TColor; > ACStop : TColor; > ARec : TRect; > ADirection : > TGradientDirection); > Var > RStart, RStop, RStep : Extended; > GStart, GStop, GStep : Extended; > BStart, BStop, BStep : Extended; > Pixel, I : Integer; > Colore : TColor; > > (* ************************************************* *) > (* ************************************************* *) > > Function _Calcola(Inizio : Extended; > Fine : Extended; > NPixel : Extended) : Extended; > Begin > If (Inizio = Fine) Or (NPixel < 1) Then > Begin > Result := 0; > Exit; > End; > > Result := (Fine-Inizio)/NPixel; > End; > (* ************************************************* *) > (* ************************************************* *) > > Begin > ACStart := ColorToRGB(ACStart); > ACStop := ColorToRGB(ACStop); > > RStart := GetRValue(ACStart); > GStart := GetGValue(ACStart); > BStart := GetBValue(ACStart); > RStop := GetRValue(ACStop); > GStop := GetGValue(ACStop); > BStop := GetBValue(ACStop); > > If ADirection = gdVertical Then Pixel := ARec.Bottom-ARec.Top+1 > Else Pixel := ARec.Right-ARec.Left+1; > RStep := _Calcola(RStart, RStop, Pixel); > GStep := _Calcola(GStart, GStop, Pixel); > BStep := _Calcola(BStart, BStop, Pixel); > > For I := 0 To Pixel-1 Do > Begin > Colore := RGB(Trunc(RStart), Trunc(GStart), > Trunc(BStart)); > ACanvas.Pen.Color := Colore; > > If ADirection = gdHorizontal Then > Begin > ACanvas.MoveTo(ARec.Left+I, ARec.Top); > ACanvas.Lineto(ARec.Left+I, ARec.Bottom); > End > Else > Begin > ACanvas.MoveTo(ARec.Left, ARec.Top+I); > ACanvas.Lineto(ARec.Right, ARec.Top+I); > End; > RStart := RStart+RStep; > GStart := GStart+GStep; > BStart := BStart+BStep; > End; > End; > > Bye, > David -- http://xpete.pt.to - Página Pessoal http://alphamatrix.org - Software Livre e Software Gratuito Português http://mosel.estg.ipleiria.pt - MOSEL - Movimento OpenSource ESTG Leiria _________________________________________________________________ To unsubscribe: mail [EMAIL PROTECTED] with "unsubscribe" as the Subject archives at http://www.lazarus.freepascal.org/mailarchives
