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
                    
00,                            // 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, 51000);

  AdjustedSize :
= size - 2*Border;

  RadiusSquared :
= SQR( MulDiv(AdjustedSize, 2,6) );

  iR :
= Border + MulDiv(AdjustedSize, 26);
  iG :
= Border + MulDiv(AdjustedSize, 36);
  iB :
= Border + MulDiv(AdjustedSize, 46);

  jOffset :
= ROUND(AdjustedSize * (2 - SQRT(3))/12);
  jR :
= jOffset + Border + Round(AdjustedSize * (2 + SQRT(3)) / 6);
  jG :
= jOffset + Border + MulDiv(AdjustedSize, 26);
  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, 51000);

  AdjustedSize :
= size - 2*Border;

  RadiusSquared :
= SQR( MulDiv(AdjustedSize, 2,6) );

  iC :
= Border + MulDiv(AdjustedSize, 26);
  iM :
= Border + MulDiv(AdjustedSize, 36);
  iY :
= Border + MulDiv(AdjustedSize, 46);

  jOffset :
= ROUND(AdjustedSize * (2 - SQRT(3))/12);
  jC :
= jOffset + Border + Round(AdjustedSize * (2 + SQRT(3)) / 6);
  jM :
= jOffset + Border + MulDiv(AdjustedSize, 26);
  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

原文地址:https://www.cnblogs.com/tulater/p/1419019.html