Delphi7,创建 RGB CMYK颜色分量圆 完整代码
作者：互联网
unit1.pas
{下面是unit1.pas}
{==============================================}
// ColorMix: Additive and Subtractive Colors
// efg, January 1999
unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ExtDlgs;
type
TForm1 = class(TForm)
CheckBoxRed: TCheckBox;
CheckBoxGreen: TCheckBox;
CheckBoxBlue: TCheckBox;
ComboBoxPrimaries: TComboBox;
ButtonSaveToFile: TButton;
ButtonPrint: TButton;
Image: TImage;
LabelLab1: TLabel;
LabelLab2: TLabel;
LabelDescribe: TLabel;
SavePictureDialog: TSavePictureDialog;
procedure FormCreate(Sender: TObject);
procedure CheckBoxClick(Sender: TObject);
procedure ButtonSaveToFileClick(Sender: TObject);
procedure ButtonPrintClick(Sender: TObject);
private
PROCEDURE UpdateEverything;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
USES
Printers; // Printer
CONST
PixelCountMax = 32768;
TYPE
TRGBTripleArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray;
//== Bitmap Manipulations ==============================================
// Based on posting to borland.public.delphi.winapi by Rodney E Geraghty,
// 8/8/97. Used to print bitmap on any Windows printer.
PROCEDURE PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
VAR
BitmapHeader: pBitmapInfo;
BitmapImage : POINTER;
HeaderSize : DWORD; // Use DWORD for compatibility with D3 and D4
ImageSize : DWORD;
BEGIN
GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
GetMem(BitmapHeader, HeaderSize);
GetMem(BitmapImage, ImageSize);
TRY
GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
StretchDIBits(Canvas.Handle,
DestRect.Left, DestRect.Top, // Destination Origin
DestRect.Right - DestRect.Left, // Destination Width
DestRect.Bottom - DestRect.Top, // Destination Height
0, 0, // Source Origin
Bitmap.Width, Bitmap.Height, // Source Width & Height
BitmapImage,
TBitmapInfo(BitmapHeader^),
DIB_RGB_COLORS,
SRCCOPY)
FINALLY
FreeMem(BitmapHeader);
FreeMem(BitmapImage)
END
END {PrintBitmap};
// Use parametric assignment of fitting circles inside cube
// of specified size.
FUNCTION CreateRGBCircles(CONST size: INTEGER;
CONST Rflag, Gflag, Bflag: BOOLEAN): TBitmap;
VAR
AdjustedSize : INTEGER;
Border : INTEGER;
i, iR,iG,iB : INTEGER;
j, jR,jG,jB : INTEGER;
jOffset : INTEGER;
RadiusSquared: INTEGER;
row : pRGBTripleArray;
FUNCTION DistanceSquared(CONST x1,y1, x2,y2: INTEGER): INTEGER;
BEGIN
RESULT := SQR(x1 - x2) + SQR(y1 - y2)
END {DistanceSquared};
BEGIN
Border := MulDiv(size, 5, 1000);
AdjustedSize := size - 2*Border;
RadiusSquared := SQR( MulDiv(AdjustedSize, 2,6) );
iR := Border + MulDiv(AdjustedSize, 2, 6);
iG := Border + MulDiv(AdjustedSize, 3, 6);
iB := Border + MulDiv(AdjustedSize, 4, 6);
jOffset := ROUND(AdjustedSize * (2 - SQRT(3))/12);
jR := jOffset + Border + Round(AdjustedSize * (2 + SQRT(3)) / 6);
jG := jOffset + Border + MulDiv(AdjustedSize, 2, 6);
jB := jR;
RESULT := TBitmap.Create;
RESULT.Width := size;
RESULT.Height := size;
RESULT.PixelFormat := pf24bit;
RESULT.Canvas.Brush.Color := RGB(0,0,0); // black
RESULT.Canvas.FillRect(RESULT.Canvas.ClipRect);
FOR j := 0 TO RESULT.Height-1 DO
BEGIN
row := RESULT.Scanline[j];
FOR i := 0 TO RESULT.Width-1 DO
BEGIN
WITH row[i] DO
BEGIN
IF Rflag AND (DistanceSquared(i,j, iR,jR) < RadiusSquared)
THEN rgbtRed := 255;
IF GFlag AND (DistanceSquared(i,j, iG,jG) < RadiusSquared)
THEN rgbtGreen := 255;
IF BFlag AND (DistanceSquared(i,j, iB,jB) < RadiusSquared)
THEN rgbtBlue := 255
END
END
END
END {CreateRGBCircles};
// Use parametric assignment of fitting circles inside cube
// of specified size.
FUNCTION CreateCMYCircles(CONST size: INTEGER;
CONST Cflag, Mflag, Yflag: BOOLEAN): TBitmap;
VAR
AdjustedSize : INTEGER;
Border : INTEGER;
i, iC,iM,iY : INTEGER;
j, jC,jM,jY : INTEGER;
jOffset : INTEGER;
RadiusSquared: INTEGER;
row : pRGBTripleArray;
FUNCTION DistanceSquared(CONST x1,y1, x2,y2: INTEGER): INTEGER;
BEGIN
RESULT := SQR(x1 - x2) + SQR(y1 - y2)
END {DistanceSquared};
BEGIN
Border := MulDiv(size, 5, 1000);
AdjustedSize := size - 2*Border;
RadiusSquared := SQR( MulDiv(AdjustedSize, 2,6) );
iC := Border + MulDiv(AdjustedSize, 2, 6);
iM := Border + MulDiv(AdjustedSize, 3, 6);
iY := Border + MulDiv(AdjustedSize, 4, 6);
jOffset := ROUND(AdjustedSize * (2 - SQRT(3))/12);
jC := jOffset + Border + Round(AdjustedSize * (2 + SQRT(3)) / 6);
jM := jOffset + Border + MulDiv(AdjustedSize, 2, 6);
jY := jC;
RESULT := TBitmap.Create;
RESULT.Width := size;
RESULT.Height := size;
RESULT.PixelFormat := pf24bit;
RESULT.Canvas.Brush.Color := RGB(255,255,255); // white
RESULT.Canvas.FillRect(RESULT.Canvas.ClipRect);
FOR j := 0 TO RESULT.Height-1 DO
BEGIN
row := RESULT.Scanline[j];
FOR i := 0 TO RESULT.Width-1 DO
BEGIN
WITH row[i] DO
BEGIN
IF Cflag AND (DistanceSquared(i,j, iC,jC) < RadiusSquared)
THEN rgbtRed := 0;
IF MFlag AND (DistanceSquared(i,j, iM,jM) < RadiusSquared)
THEN rgbtGreen := 0;
IF YFlag AND (DistanceSquared(i,j, iY,jY) < RadiusSquared)
THEN rgbtBlue := 0;
END
END
END
END {CreateCMYCircles};
PROCEDURE TForm1.UpdateEverything;
VAR
Bitmap: TBitmap;
BEGIN
IF ComboBoxPrimaries.ItemIndex = 0
THEN Bitmap := CreateRGBCircles(Image.Width,
CheckBoxRed.Checked,
CheckBoxGreen.Checked,
CheckBoxBlue.Checked)
ELSE Bitmap := CreateCMYCircles(Image.Width,
CheckBoxRed.Checked,
CheckBoxGreen.Checked,
CheckBoxBlue.Checked);
TRY
Image.Picture.Graphic := Bitmap;
FINALLY
Bitmap.Free
END;
END;
procedure TForm1.FormCreate(Sender: TObject);
begin
ComboBoxPrimaries.ItemIndex := 0;
UpdateEverything
end;
procedure TForm1.CheckBoxClick(Sender: TObject);
begin
IF ComboBoxPrimaries.ItemIndex = 0
THEN LabelDescribe.Caption := 'Add to Black'
ELSE LabelDescribe.Caption := 'Subtract from White';
UpdateEverything
end;
procedure TForm1.ButtonSaveToFileClick(Sender: TObject);
CONST
ImageSizeForFile = 512;
VAR
Bitmap: TBitmap;
BEGIN
IF SavePictureDialog.Execute
THEN BEGIN
IF ComboBoxPrimaries.ItemIndex = 0
THEN Bitmap := CreateRGBCircles(ImageSizeForFile,
CheckBoxRed.Checked,
CheckBoxGreen.Checked,
CheckBoxBlue.Checked)
ELSE Bitmap := CreateCMYCircles(ImageSizeForFile,
CheckBoxRed.Checked,
CheckBoxGreen.Checked,
CheckBoxBlue.Checked);
TRY
Bitmap.SavetoFile(SavePictureDialog.Filename);
ShowMessage('File ' + SavePictureDialog.Filename + ' written.')
FINALLY
Bitmap.Free
END
END
end;
procedure TForm1.ButtonPrintClick(Sender: TObject);
CONST
iMargin = 8; // 8% margin left and right
jMargin = 10; // 10% margin top and bottom
VAR
iFromLeftMargin : INTEGER;
iPrintedImageWidth : INTEGER;
jFromPageMargin : INTEGER;
jPrintedImageHeight: INTEGER;
s : STRING;
TargetRectangle : TRect;
begin
Printer.Orientation := poPortrait;
Printer.BeginDoc;
TRY
iFromLeftMargin := MulDiv(Printer.PageWidth, iMargin, 100);
jFromPageMargin := MulDiv(Printer.PageHeight, jMargin, 100);
iPrintedImageWidth := MulDiv(Printer.PageWidth, 100-2*iMargin, 100);
jPrintedImageHeight := iPrintedImageWidth; // Aspect ratio is 1 for these images
TargetRectangle := Rect(iFromLeftMargin, jFromPageMargin,
iFromLeftMargin + iPrintedImageWidth,
jFromPageMargin + jPrintedImageHeight);
// Header
Printer.Canvas.Font.Size := 14;
Printer.Canvas.Font.Name := 'Arial';
Printer.Canvas.Font.Color := clBlack;
Printer.Canvas.Font.Style := [fsBold];
s := ComboBoxPrimaries.Text;
Printer.Canvas.TextOut(
(Printer.PageWidth - Printer.Canvas.TextWidth(s)) DIV 2, // center
jFromPageMargin - 3*Printer.Canvas.TextHeight(s) DIV 2,
s);
// Bitmap
PrintBitmap(Printer.Canvas, TargetRectangle, Image.Picture.Bitmap);
// Footer
Printer.Canvas.Font.Size := 12;
Printer.Canvas.Font.Name := 'Arial';
Printer.Canvas.Font.Color := clBlue;
Printer.Canvas.Font.Style := [fsBold, fsItalic];
s := 'efg''s Computer Lab';
Printer.Canvas.TextOut(iFromLeftMargin,
Printer.PageHeight -
Printer.Canvas.TextHeight(s),
s);
Printer.Canvas.Font.Style := [fsBold];
s := 'www.efg2.com/lab';
Printer.Canvas.TextOut(Printer.PageWidth -
iFromLeftMargin -
Printer.Canvas.TextWidth(s),
Printer.PageHeight -
Printer.Canvas.TextHeight(s),
s)
FINALLY
Printer.EndDoc
END;
ShowMessage ('Image Printed')
end;
end.
unit1.dfm
{==============================================}{下面是unit1.dfm}
{==============================================}
object Form1: TForm1
Left = 635
Top = 90
Width = 696
Height = 480
Caption = 'CheckBoxBlue'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Image: TImage
Left = 54
Top = 204
Width = 105
Height = 105
end
object LabelLab1: TLabel
Left = 229
Top = 208
Width = 50
Height = 13
Caption = 'LabelLab1'
end
object LabelLab2: TLabel
Left = 235
Top = 246
Width = 50
Height = 13
Caption = 'LabelLab2'
end
object LabelDescribe: TLabel
Left = 243
Top = 270
Width = 68
Height = 13
Caption = 'LabelDescribe'
end
object CheckBoxRed: TCheckBox
Left = 61
Top = 45
Width = 97
Height = 17
Caption = 'CheckBoxRed'
TabOrder = 0
OnClick = CheckBoxClick
end
object CheckBoxGreen: TCheckBox
Left = 58
Top = 75
Width = 97
Height = 17
Caption = 'CheckBoxGreen'
TabOrder = 1
OnClick = CheckBoxClick
end
object CheckBoxBlue: TCheckBox
Left = 56
Top = 106
Width = 97
Height = 17
Caption = 'CheckBoxBlue'
TabOrder = 2
OnClick = CheckBoxClick
end
object ComboBoxPrimaries: TComboBox
Left = 52
Top = 139
Width = 145
Height = 21
ItemHeight = 13
TabOrder = 3
Text = 'ComboBoxPrimaries'
Items.Strings = (
#27491#24120
#32418
#32511
#34013)
end
object ButtonSaveToFile: TButton
Left = 17
Top = 345
Width = 151
Height = 25
Caption = 'ButtonSaveToFile'
TabOrder = 4
end
object ButtonPrint: TButton
Left = 19
Top = 383
Width = 75
Height = 25
Caption = 'ButtonPrint'
TabOrder = 5
end
object SavePictureDialog: TSavePictureDialog
Left = 249
Top = 139
end
end
发表于 2009-03-22 16:00 涂磊 阅读(821) 评论(0) 编辑 收藏
标签：Canvas,Printer,Height,CMYK,Width,RGB,Delphi7,RESULT,INTEGER 来源： https://blog.51cto.com/u_15216366/2823479