Delphi7,创建RGBCMYK颜色分量圆完整代码

原作者: [db:作者] 来自: [db:来源] 收藏邀请

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

鲜花

握手

雷人

路过

鸡蛋

该文章已有0人参与评论

请发表评论

全部评论

专题导读

More+

10-27 六六分期app的软件客服如何联系？(六六分期

11-06 可心卡盟:win10系统火狐flash插件崩溃怎么

11-06 亲亲特价:怎么删除回收站图标

11-06 济南大学虚拟社区:鲁大师节能降温的具体办

11-06 xlueops.exe:无线网络安装向导

11-06 女斗合众国:win7系统cf与主机连接不稳定怎

11-06 0xc000022-[cf烟雾头]cf怎么调烟雾头

11-06 qizideyouhuo:应用程序无法正常启动0xc0000

11-06 ipz-185:win7系统vcf文件怎么打开

11-06 傻哥蹦迪:win10系统s4怎么打开usb调试

11-06 八神浩树gtaste:回收站清空了怎么恢复

11-06 妖尾之黑色守护:win10系统电脑没有1440x900

11-06 校园至尊魔王小说:win7系统浏览网页时字体

11-06 女斗合众国:win10系统访问共享文件夹提示请

11-06 tokyo hot n0654:恢复win7系统默认字体一招

11-06 雨酷仙境:设置win7系统转移临时文件夹腾出

11-06 阿穆纳伊之杖:win7系统开始菜单在右边还原

11-06 tunespotting:win10系统火狐flash插件总是

11-06 甘尔葛分析师：计谋网站seo关键词暴涨有什

11-06 蔡贵霖: 计谋网站seo关键词暴涨有什么秘密

11-06 博益网首页:ao3网页版进入不了解决方法

11-06 漏斗子专栏: 网站数据分析小白易懂精华篇

11-06 见证双虹怎么做:win7系统开启telnet命令的

11-06 颾狐蝶蜋:系统资源不足无法完成请求的服务

11-06 国光中学校歌:提交网站到alexa查询详细步骤

11-06 西安有情天:静态网页和动态网页的区别

11-06 红木雅尚斋:外部链接构造对网站的好处

11-06 前官礼遇：防止域名劫持–增强域安全性的10

11-06 密传二转答案: 中文分词算法有哪些

11-06 金泉家园邮编:百度快照劫持的表现及应对方

delphi 版 sqlHelper第二版发布时间：2022-07-18

delphiwin64DEBUG不能进预设断点的问题发布时间：2022-07-18

剪的笔顺,诠释剪的笔画,认识剪的部首

1 六六分期app的软件客服如何联系？(六六分期

六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期

阅读：19212|2023-10-27

2 可心卡盟:win10系统火狐flash插件崩溃怎么

今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知

阅读：9994|2022-11-06

3 亲亲特价:怎么删除回收站图标

今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道

阅读：8331|2022-11-06

4 济南大学虚拟社区:鲁大师节能降温的具体办

今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要

阅读：8699|2022-11-06

5 xlueops.exe:无线网络安装向导

我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多

阅读：8642|2022-11-06

6 女斗合众国:win7系统cf与主机连接不稳定怎

今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不

阅读：9663|2022-11-06

7 0xc000022-[cf烟雾头]cf怎么调烟雾头

电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很

阅读：8627|2022-11-06

8 qizideyouhuo:应用程序无法正常启动0xc0000

我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法

阅读：8003|2022-11-06

9 ipz-185:win7系统vcf文件怎么打开

今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win

阅读：8660|2022-11-06

10 傻哥蹦迪:win10系统s4怎么打开usb调试

今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎

阅读：7537|2022-11-06

客服电话

电子邮件

Delphi7,创建RGBCMYK颜色分量圆完整代码

请发表评论

全部评论

上一篇：

下一篇：

CVE-2022-28370

hashicorp/vault-plugin-auth-kubernetes:

krishnaik06/Machine-Learning-in-90-days

armancodv/building-energy-model-matlab:

美元符号为什么是“$”

剪的笔顺,诠释剪的笔画,认识剪的部首

六六分期app的软件客服如何联系？(六六分期

florent37/ViewAnimator: A fluent Android

florent37/Shrine-MaterialDesign2: implem

CVE-2020-36276

SimpleSoftwareIO/simple-sms: Send and re

关于我们

产品与服务

解决方案

139-2527-9053