graphic32methodfordelphi.txt

32位图像处理库delphi简单实现 TBitmap可以设置 ［pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32

 32位图像处理库delphi简单实现 


Posted on 2006-05-06 22:16 大名鼎鼎 阅读(52) 评论(0)  编辑 收藏 引用 收藏至365Key  
unit Image32;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, ComCtrls, ToolWin, ImgList, GraphicEx, Jpeg,
  Buttons, Math, Trace, mmsystem;

const
    PixelCountMax = 32768;
    bias = $00800080;
    // Some predefined color constants

type
  TRGBQuad = packed record
    rgbBlue: BYTE;
    rgbGreen: BYTE;
    rgbRed: BYTE;
    rgbReserved: BYTE;
  end;


  PColor32 = ^TColor32;
  TColor32 = type Cardinal;

  PColor32Array = ^TColor32Array;
  TColor32Array = array [0..0] of TColor32;
  TArrayOfColor32 = array of TColor32;

  pRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = array[0..PixelCountMax - 1] of TRGBQuad;

  PRGBArray = ^TRGBArray;
  {* RGB数组指针}
  TRGBArray = array[0..8192] of tagRGBTriple;
  {* RGB数组类型}




  TGradualStyle = (gsLeftToRight, gsRightToLeft, gsTopToBottom, gsBottomToTop,
    gsCenterToLR, gsCenterToTB);
  {* 渐变方式类型
   |<PRE>
     gsLeftToRight      - 从左向右渐变
     gsRightToLeft      - 从右向左渐变
     gsTopToBottom      - 从上向下渐变
     gsBottomToTop      - 从下向上渐变
     gsCenterToLR       - 从中间向左右渐变
     gsCenterToTB       - 从中间向上下渐变
   |</PRE>}
  TTextureMode = (tmTiled, tmStretched, tmCenter, tmNormal);
  {* 纹理图像显示模式
   |<PRE>
     tmTiled            - 平铺显示
     tmStretched        - 自动缩放显示
     tmCenter           - 在中心位置显示
     tmNormal           - 在左上角显示
   |</PRE>}    


  function RedComponent(Color32: TColor32): Integer;           //取得32位色的红色通道
  function GreenComponent(Color32: TColor32): Integer;         //取得32位色的绿色通道
  function BlueComponent(Color32: TColor32): Integer;          //取得32位色的蓝色通道
  function AlphaComponent(Color32: TColor32): Integer;         //取得32位色的ALPHA(透明）通道
  function Intensity(Color32: TColor32): Integer;              //计算灰度
  function RGBA(R, G, B: Byte; A: Byte = $00): TColor32;       //
  function RGBAToColor32(RGBA: TRGBQuad): TColor32;            //
  function Color32ToRGBA(Color32: TColor32): TRGBQuad;         //

  { An analogue of FillChar for 32 bit values }
  procedure FillLongword(var X; Count: Integer; Value: Longword);

const
                     ALPHA(0-255，不透明-透明） Red, Green, Blue
  clBlack32               : TColor32 = $00000000;
  clDimGray32             : TColor32 = $003F3F3F;
  clGray32                : TColor32 = $007F7F7F;
  clLightGray32           : TColor32 = $00BFBFBF;
  clWhite32               : TColor32 = $00FFFFFF;
  clMaroon32              : TColor32 = $007F0000;
  clGreen32               : TColor32 = $00007F00;
  clOlive32               : TColor32 = $007F7F00;
  clNavy32                : TColor32 = $0000007F;
  clPurple32              : TColor32 = $007F007F;
  clTeal32                : TColor32 = $00007F7F;
  clRed32                 : TColor32 = $00FF0000;
  clLime32                : TColor32 = $0000FF00;
  clYellow32              : TColor32 = $00FFFF00;
  clBlue32                : TColor32 = $000000FF;
  clFuchsia32             : TColor32 = $00FF00FF;
  clAqua32                : TColor32 = $0000FFFF;

  // Some semi-transparent color constants
  clTrWhite32             : TColor32 = $7FFFFFFF;
  clTrBlack32             : TColor32 = $7F000000;
  clTrRed32               : TColor32 = $7FFF0000;
  clTrGreen32             : TColor32 = $7F00FF00;
  clTrBlue32              : TColor32 = $7F0000FF;      

type
  TBitmap32 = class(TBitmap)
  private

  protected
  public
    constructor Create; override;                                   //重载，设置为32位 PixelFormat := pf32bit
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;                //重载，设置为32位
    procedure LoadFromFile(const Filename: string); override;       //重载，设置为32位

// 这两个函数引用自FLIB //
// 只处理目标ALPHA通道时,两个函数可以替换到用 //

//  注意这里一下, 替换时请在DrawTo,DrawFrom 里面替换就可以了

// CombinAlphaPixel是以目标及源像素的ALPHA通道合成
    procedure CombineAlphaPixel(var pDest: TRGBQuad; cr1: TRGBQuad; nAlpha1: integer; cr2: TRGBQuad; nAlpha2: integer);
// AlphaBlendPixel是以目标的ALPHA通道合成
    /://
{    把这个函数写到DrawTo函数以替换CombineAlphaPiexl
     
图层的概念
[
最下层是画布(就是一个TBitmap32对像,也可以是Image1.Picture.Bitmap)
跟着上面的就是图层啦,文字层什么的
]


从最下层的32位图像画起
就可以把许多个32位图层到画布上,显示出来


procedure TBitmap32.DrawTo(DstX, DstY: Integer; Tge: TBitmap);
var
    x, y: integer;
    TR, SR: TRect;
    Source, Target: pRGBQuadArray;
begin
    Tge.PixelFormat := pf32bit;
    SetAlphaChannels(Tge, $FF);

    Tr := Rect(0, 0, Tge.Width, Tge.Height);
    SR := Rect(DstX, DstY, DstX + Width, DstY + Height);

    if IntersectRect(Tr, Tr, SR) = false then
    exit;

    for y := Tr.Top to Tr.Bottom - 1 do
    begin
        Target := Tge.ScanLine[y];
        Source := ScanLine[y - Dsty];


        for x := Tr.Left to Tr.Right - 1 do
        begin
//这里替换了
//            CombineAlphaPixel(Target^[x], Target^[x], Target^[x].rgbReserved, Source^[x - DstX], Source^[x- DstX].rgbReserved);
            AlphaBlendPixel(Target^[x], Source^[x - DstX]);
        end;


    end;

end;

for i := 0 to LayerList.Count -1 do 
begin
    TBitmap32(LayerList.Items[i ]).DrawTo(0,0, Image1.Picture.Bitmap);
end;
}
    //o//

    procedure AlphaBlendPixel(var pDest: TRGBQuad; pSrc: TRGBQuad);

    function  GetBits: PColor32Array;                      //获得图像的起始地址
    procedure SetPixel(x, y: integer; color: TColor32);    //在x,y座标画点
    function  GetPixel(x, y: integer): TColor32;           //取得x,y座标点的颜色

    function  GetPixelPtr(Left, Top: Integer): PColor32;

    procedure  Clear(color: TColor32);overload;
    procedure  Clear(Bitmap: TBitmap; color: TColor32);overload;
    procedure  Clear;overload;    
    procedure  FillRect(X1, Y1, X2, Y2: Integer; Color: TColor32);


    procedure  SetAlphaChannels(Alpha: BYTE);overload;                              //设置透明通道
    procedure  SetAlphaChannels(Bitmap: TBitmap; Alpha: Byte);overload;
    procedure  SetAlphaChannels(Mask8: TBitmap);overload;

    procedure DrawFrom(DstX, DstY: Integer; Src: TBitmap32);                //把图像写到自身
    procedure DrawTo(DstX, DstY: Integer; Tge: TBitmap32);overload;         //把自身写到图像
    procedure DrawTo(DstX, DstY: Integer; Tge: TBitmap);overload;


    procedure CreateGradual(Style: TGradualStyle; StartColor, EndColor: TColor);
    procedure DrawTiled(Canvas: TCanvas; Rect: TRect; G: TGraphic);
    procedure CreateForeBmp(Mode: TTextureMode; G: TGraphic; BkColor: TColor);

    property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr;    

  end;

implementation

procedure FillLongword(var X; Count: Integer; Value: Longword);
asm
// EAX = X
// EDX = Count
// ECX = Value
        PUSH    EDI

        MOV     EDI,EAX  // Point EDI to destination              
        MOV     EAX,ECX
        MOV     ECX,EDX
        TEST    ECX,ECX
        JS      @exit

        REP     STOSD    // Fill count dwords
@exit:
        POP     EDI
end;

function RedComponent(Color32: TColor32): Integer;
begin
  Result := (Color32 and $00FF0000) shr 16;
end;

function GreenComponent(Color32: TColor32): Integer;
begin
  Result := (Color32 and $0000FF00) shr 8;
end;

function BlueComponent(Color32: TColor32): Integer;
begin
  Result := Color32 and $000000FF;
end;

function AlphaComponent(Color32: TColor32): Integer;
begin
  Result := Color32 shr 24;
end;

function Intensity(Color32: TColor32): Integer;
begin
// (R * 61 + G * 174 + B * 21) / 256
  Result := (
    (Color32 and $00FF0000) shr 16 * 61 +
    (Color32 and $0000FF00) shr 8 * 174 +
    (Color32 and $000000FF) * 21
    ) shr 8;
end;

function RGBA(R, G, B: Byte; A: Byte = $00): TColor32;
begin
  Result := A shl 24 + R shl 16 + G shl 8 + B;
end;

function RGBAToColor32(RGBA: TRGBQuad): TColor32;
begin
  Result := RGBA.rgbReserved shl 24 + RGBA.rgbRed shl 16 + RGBA.rgbGreen shl 8 + RGBA.rgbBlue;
end;

function Color32ToRGBA(Color32: TColor32): TRGBQuad;
var
    RGBA: TRGBQuad;
begin
     RGBA.rgbRed := RedComponent(Color32);
     RGBA.rgbRed := GreenComponent(Color32);
     RGBA.rgbRed := BlueComponent(Color32);
     RGBA.rgbRed := AlphaComponent(Color32);
     Result := RGBA;
end;

constructor TBitmap32.Create;
begin
    inherited Create;
    PixelFormat := pf32bit;
end;

destructor TBitmap32.Destroy;
begin
    inherited Destroy;
end;

function TBitmap32.GetPixelPtr(Left, Top: Integer): PColor32;
begin
  Result := @GetBits[Top * Width + Left];
end;

function TBitmap32.GetBits: PColor32Array;
begin
    Result := ScanLine[Height - 1];
end;


procedure TBitmap32.DrawFrom(DstX, DstY: Integer; Src: TBitmap32);
var
    x, y: integer;
    TR, SR: TRect;
    Source, Target: pRGBQuadArray;
begin

    TR := Rect(0, 0, Width, Height);
    SR := Rect(DstX, DstY, DstX + Src.Width, DstY + Src.Height);

    if IntersectRect(TR, TR, SR) = false then
    exit;

    for y := Tr.Top to Tr.Bottom - 1 do
    begin
        Source := Src.ScanLine[y - Dsty];
        Target := ScanLine[y];
        for x := TR.Left to Tr.Right - 1 do
        begin
            CombineAlphaPixel(Target^[x], Target^[x], Target^[x].rgbReserved, Source^[x - DstX], Source^[x- DstX].rgbReserved);
//            AlphaBlendPixel(Target^[x], Source^[x - DstX]);
        end;
    end;
end;

procedure TBitmap32.DrawTo(DstX, DstY: Integer; Tge: TBitmap32);
var
    x, y: integer;
    TR, SR: TRect;
    Source, Target: pRGBQuadArray;
begin

    TR := Rect(0, 0, TGe.Width, Tge.Height);
    SR := Rect(DstX, DstY, DstX + Width, DstY + Height);

    if IntersectRect(TR, TR, SR) = false then
    exit;

    for y := Tr.Top to Tr.Bottom - 1 do
    begin
        Target := Tge.ScanLine[y];
        Source := ScanLine[y - Dsty];
        for x := TR.Left to Tr.Right - 1 do
        begin
            CombineAlphaPixel(Target^[x], Target^[x], Target^[x].rgbReserved, Source^[x - DstX], Source^[x- DstX].rgbReserved);
//            AlphaBlendPixel(Target^[x], Source^[x -DstX]);
        end;
    end;

end;


///////////  LOGO Insert TO

procedure TBitmap32.DrawTo(DstX, DstY: Integer; Tge: TBitmap);
var
    x, y: integer;
    TR, SR: TRect;
    Source, Target: pRGBQuadArray;
begin
    Tge.PixelFormat := pf32bit;
    SetAlphaChannels(Tge, $FF);

    Tr := Rect(0, 0, Tge.Width, Tge.Height);
    SR := Rect(DstX, DstY, DstX + Width, DstY + Height);

    if IntersectRect(Tr, Tr, SR) = false then
    exit;

    for y := Tr.Top to Tr.Bottom - 1 do