Delphi控件源码

开发平台：
Delphi

ImgUtil.pas：源码内容
							{$R-}  // Turn off Range Checking because of ARRAY[0..0] construct below
unit ImgUtil;
// The new algorithms are 5 to 8 imes faster (dirty but fast) and they
// not need so many memory (if the bitmap very large you have a problem ->
// windows must use the swapfile).
//{$WARNINGS OFF}
//{$HINTS OFF}
interface
uses   Windows, Graphics,math;
  procedure SpiegelnHorizontal  (Bitmap:TBitmap);
  procedure SpiegelnVertikal    (Bitmap:TBitmap);
  procedure Drehen90Grad        (Bitmap:TBitmap);
  procedure Drehen270Grad       (Bitmap:TBitmap);
  procedure Drehen180Grad       (Bitmap:TBitmap);
  FUNCTION Rotate90(Bitmap:TBitmap):  TBitmap;
  procedure ConvertBitmapToGrayscale (const Bmp: TBitmap);
  procedure ChangeTrans(abmp:Tbitmap;colorf:Tcolor);
  function Blend(C1, C2: TColor; W1: Integer): TColor;
  procedure GradFill(DC: HDC; ARect: TRect; ClrTopLeft, ClrBottomRight: TColor; Kind: integer = 1);
  function GetHSV(c:Tcolor):integer;
implementation
USES dialogs,
     Classes,    // Rect
     SysUtils;
TYPE
  EBitmapError = CLASS(Exception);
  TRGBArray    = ARRAY[0..0] OF TRGBTriple;
  pRGBArray    = ^TRGBArray;
procedure ConvertBitmapToGrayscale (const Bmp: TBitmap);
var
  x, y, Gray: Integer;
  Row: PRGBArray;
begin
  Bmp.PixelFormat := pf24Bit;
  for y := 0 to Bmp.Height - 1 do
  begin
    Row := Bmp.ScanLine[y];
    for x := 0 to Bmp.Width - 1 do
    begin
      Gray           := (Row[x].rgbtRed + Row[x].rgbtGreen + Row[x].rgbtBlue) div 3;
      Row[x].rgbtRed := Gray;
      Row[x].rgbtGreen := Gray;
      Row[x].rgbtBlue := Gray;
    end;
  end;
end;
procedure ChangeTrans(abmp:Tbitmap;colorf:Tcolor);
var x, y, Gray: Integer;
    Row: PRGBArray;
    r,g,b:integer;
begin
   r:=GetRValue(colorf);
   g:=GetGValue(colorf);
   b:=GetBValue(colorf);
   if (abmp.PixelFormat<>pf24bit) then
     abmp.PixelFormat:=pf24bit;
   for y := 0 to aBmp.Height - 1 do  begin
    Row := aBmp.ScanLine[y];
    for x := 0 to aBmp.Width - 1 do begin
      if (Row[x].rgbtRed=255) and
         (Row[x].rgbtGreen=0) and
         (Row[x].rgbtBlue =255) then begin
           Row[x].rgbtRed:=r;
           Row[x].rgbtGreen:=g;
           Row[x].rgbtBlue :=b;
      end;
    end;
  end;
end;
procedure SpiegelnHorizontal(Bitmap:TBitmap);
var i,j,w,n :  INTEGER;
    RowIn :  pRGBArray;
    RowOut:  pRGBArray;
    temp:Tbitmap;
begin
    temp:=Tbitmap.create;
    temp.Width  := Bitmap.Width;
    temp.Height := Bitmap.Height;
    temp.PixelFormat := Bitmap.PixelFormat;    // only pf24bit for now
    n:=bitmap.width;
    for j := 0 to Bitmap.Height-1 do begin
      rowout := temp.Scanline[j];
      rowin := Bitmap.Scanline[j];
      for i := 0 to n-1 do rowout[i] := rowin[n-1-i];
    end;
    bitmap.Assign(temp);
    temp.free;
end;
procedure SpiegelnVertikal(Bitmap : TBitmap);
var j,w :  INTEGER;
    help  :  TBitmap;
begin
    help := TBitmap.Create;
    help.Width       := Bitmap.Width;
    help.Height      := Bitmap.Height;
    help.PixelFormat := Bitmap.PixelFormat;
    w := Bitmap.Width*sizeof(TRGBTriple);
    for j := 0 to Bitmap.Height-1 do move(Bitmap.Scanline[j]^,Help.Scanline[Bitmap.Height - 1 - j]^,w);
    Bitmap.Assign(help);
    help.free;
end;
type THelpRGB = packed record
                   rgb    : TRGBTriple;
                   dummy  : byte;
                end;
procedure Drehen270Grad(Bitmap:TBitmap);
var aStream : TMemorystream;
    header  : TBITMAPINFO;
    dc      : hDC;
    P       : ^THelpRGB;
    x,y,b,h : Integer;
    RowOut:  pRGBArray;
BEGIN
   aStream := TMemoryStream.Create;
   aStream.SetSize(Bitmap.Height*Bitmap.Width * 4);
   with header.bmiHeader do begin
     biSize := SizeOf(TBITMAPINFOHEADER);
     biWidth := Bitmap.Width;
     biHeight := Bitmap.Height;
     biPlanes := 1;
     biBitCount := 32;
     biCompression := 0;
     biSizeimage := aStream.Size;
     biXPelsPerMeter :=1;
     biYPelsPerMeter :=1;
     biClrUsed :=0;
     biClrImportant :=0;
   end;
   dc := GetDC(0);
   P  := aStream.Memory;
   GetDIBits(dc,Bitmap.Handle,0,Bitmap.Height,P,header,dib_RGB_Colors);
   ReleaseDC(0,dc);
   b := bitmap.Height;  // rotate
   h := bitmap.Width;   // rotate
   bitmap.Width := b;
   bitmap.height := h;
   for y := 0 to (h-1) do begin
     rowOut := Bitmap.ScanLine[(h-1)-y];
     P  := aStream.Memory;        // reset pointer
     inc(p,y);
     for x := (b-1) downto 0 do begin
        rowout[x] := p^.rgb;
        inc(p,h);
     end;
   end;
   aStream.Free;
end;
procedure Drehen90Grad(Bitmap:TBitmap);
var aStream : TMemorystream;
    header  : TBITMAPINFO;
    dc      : hDC;
    P       : ^THelpRGB;
    x,y,b,h : Integer;
    RowOut:  pRGBArray;
BEGIN
   aStream := TMemoryStream.Create;
   aStream.SetSize(Bitmap.Height*Bitmap.Width * 4);
   with header.bmiHeader do begin
     biSize := SizeOf(TBITMAPINFOHEADER);
     biWidth := Bitmap.Width;
     biHeight := Bitmap.Height;
     biPlanes := 1;
     biBitCount := 32;
     biCompression := 0;
     biSizeimage := aStream.Size;
     biXPelsPerMeter :=1;
     biYPelsPerMeter :=1;
     biClrUsed :=0;
     biClrImportant :=0;
   end;
   dc := GetDC(0);
   P  := aStream.Memory;
   GetDIBits(dc,Bitmap.Handle,0,Bitmap.Height,P,header,dib_RGB_Colors);
   ReleaseDC(0,dc);
   b := bitmap.Height;  // rotate
   h := bitmap.Width;   // rotate
   bitmap.Width := b;
   bitmap.height := h;
   for y := 0 to (h-1) do begin
     rowOut := Bitmap.ScanLine[y];
     P  := aStream.Memory;        // reset pointer
     inc(p,y);
     for x := 0 to (b-1) do begin
        rowout[x] := p^.rgb;
        inc(p,h);
     end;
   end;
   aStream.Free;
end;
procedure Drehen180Grad(Bitmap:TBitmap);
var i,j     :  INTEGER;
    rowIn :  pRGBArray;
    rowOut:  pRGBArray;
    help  : TBitmap;
begin
   help := TBitmap.Create;
   help.Width  := Bitmap.Width;
   help.Height := Bitmap.Height;
   help.PixelFormat := Bitmap.PixelFormat;    // only pf24bit for now
   FOR  j := 0 TO Bitmap.Height - 1 DO BEGIN
     rowIn  := Bitmap.ScanLine[j];
     rowOut := help.ScanLine[Bitmap.Height - j - 1];
     FOR i := 0 TO Bitmap.Width - 1 DO rowOut[Bitmap.Width - i - 1] := rowIn[i]
   END;
   bitmap.assign(help);
   help.free;
end;
FUNCTION Rotate90(Bitmap:TBitmap):  TBitmap;
VAR i,j     :  INTEGER;
        rowIn :  pRGBArray;
BEGIN
   IF   Bitmap.PixelFormat <> pf24bit then
     exit;
   RESULT := TBitmap.Create;
   RESULT.Width  := Bitmap.Height;
   RESULT.Height := Bitmap.Width;
   RESULT.PixelFormat := Bitmap.PixelFormat;    // only pf24bit for now
   // Out[j, Right - i - 1] = In[i, j]
   FOR  j := 0 TO Bitmap.Height - 1 DO  BEGIN
      rowIn  := Bitmap.ScanLine[j];
      FOR i := 0 TO Bitmap.Width - 1 DO
          pRGBArray(RESULT.ScanLine[Bitmap.Width - i - 1])[j] := rowIn[i]
   END;
END;
function Blend(C1, C2: TColor; W1: Integer): TColor;
var
  W2, A1, A2, D, F, G: Integer;
begin
  if C1 < 0 then C1 := GetSysColor(C1 and $FF);
  if C2 < 0 then C2 := GetSysColor(C2 and $FF);
  if W1 >= 100 then D := 1000
  else D := 100;
  W2 := D - W1;
  F := D div 2;
  A2 := C2 shr 16 * W2;
  A1 := C1 shr 16 * W1;
  G := (A1 + A2 + F) div D and $FF;
  Result := G shl 16;
  A2 := (C2 shr 8 and $FF) * W2;
  A1 := (C1 shr 8 and $FF) * W1;
  G := (A1 + A2 + F) div D and $FF;
  Result := Result or G shl 8;
  A2 := (C2 and $FF) * W2;
  A1 := (C1 and $FF) * W1;
  G := (A1 + A2 + F) div D and $FF;
  Result := Result or G;
end;
const
  GRADIENT_CACHE_SIZE = 16;
type
  PRGBQuad = ^TRGBQuad;
  TRGBQuad = Integer;
  PRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = array [0..0] of TRGBQuad;
var
  GradientCache: array [0..GRADIENT_CACHE_SIZE] of array of TRGBQuad;
  NextCacheIndex: Integer = 0;
function FindGradient(Size: Integer; CL, CR: TRGBQuad): Integer;
begin
  Assert(Size > 0);
  Result := GRADIENT_CACHE_SIZE - 1;
  while Result >= 0 do
  begin
    if (Length(GradientCache[Result]) = Size) and
      (GradientCache[Result][0] = CL) and
      (GradientCache[Result][Length(GradientCache[Result]) - 1] = CR) then Exit;
    Dec(Result);
  end;
end;
function MakeGradient(Size: Integer; CL, CR: TRGBQuad): Integer;
var
  R1, G1, B1: Integer;
  R2, G2, B2: Integer;
  R, G, B: Integer;
  I: Integer;
  Bias: Integer;
begin
  Assert(Size > 0);
  Result := NextCacheIndex;
  Inc(NextCacheIndex);
  if NextCacheIndex >= GRADIENT_CACHE_SIZE then NextCacheIndex := 0;
  R1 := CL and $FF;
  G1 := CL shr 8 and $FF;
  B1 := CL shr 16 and $FF;
  R2 := CR and $FF - R1;
  G2 := CR shr 8 and $FF - G1;
  B2 := CR shr 16 and $FF - B1;
  SetLength(GradientCache[Result], Size);
  Dec(Size);
  Bias := Size div 2;
  if Size > 0 then
    for I := 0 to Size do
    begin
      R := R1 + (R2 * I + Bias) div Size;
      G := G1 + (G2 * I + Bias) div Size;
      B := B1 + (B2 * I + Bias) div Size;
      GradientCache[Result][I] := R + G shl 8 + B shl 16;
    end
  else
  begin
    R := R1 + R2 div 2;
    G := G1 + G2 div 2;
    B := B1 + B2 div 2;
    GradientCache[Result][0] := R + G shl 8 + B shl 16;
  end;
end;
function GetGradient(Size: Integer; CL, CR: TRGBQuad): Integer;
begin
  Result := FindGradient(Size, CL, CR);
  if Result < 0 then Result := MakeGradient(Size, CL, CR);
end;
procedure GradFill(DC: HDC; ARect: TRect; ClrTopLeft, ClrBottomRight: TColor; Kind: integer = 1);
const
//  GRAD_MODE: array [0..1] of DWORD = (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V);
  W: array [0..1] of Integer = (2, 1);
  H: array [0..1] of Integer = (1, 2);
type
  TriVertex = packed record
    X, Y: Longint;
    R, G, B, A: Word;
  end;
var
  V: array [0..1] of TriVertex;
  GR: GRADIENT_RECT;
  Size, I, Start, Finish: Integer;
  GradIndex: Integer;
  R, CR: TRect;
  Brush: HBRUSH;
begin
  if not RectVisible(DC, ARect) then Exit;
  ClrTopLeft := ColorToRGB(ClrTopLeft);
  ClrBottomRight := ColorToRGB(ClrBottomRight);
    { Have to do it manually if msimg32.dll is not available }
    GetClipBox(DC, CR);
    if Kind = 0 then begin
      Size := ARect.Right - ARect.Left;
      if Size <= 0 then Exit;
      Start := 0; Finish := Size - 1;
      if CR.Left > ARect.Left then Inc(Start, CR.Left - ARect.Left);
      if CR.Right < ARect.Right then Dec(Finish, ARect.Right - CR.Right);
      R := ARect; Inc(R.Left, Start); R.Right := R.Left + 1;
    end else begin
      Size := ARect.Bottom - ARect.Top;
      if Size <= 0 then Exit;
      Start := 0; Finish := Size - 1;
      if CR.Top > ARect.Top then Inc(Start, CR.Top - ARect.Top);
      if CR.Bottom < ARect.Bottom then Dec(Finish, ARect.Bottom - CR.Bottom);
      R := ARect; Inc(R.Top, Start); R.Bottom := R.Top + 1;
    end;
    GradIndex := GetGradient(Size, ClrTopLeft, ClrBottomRight);
    for I := Start to Finish do begin
      Brush := CreateSolidBrush(GradientCache[GradIndex][I]);
      Windows.FillRect(DC, R, Brush);
      OffsetRect(R, Integer(Kind = 0), Integer(Kind = 1));
      DeleteObject(Brush);
    end;
end;
function GetHSV(c:Tcolor):integer;
var
  Delta:  double;
  Min  :  double;
  R,G,B:  integer;
  ss,vv,hh:double;
  H,S,V:Integer;
begin
    R := C and $FF;
    G := C shr 8 and $FF;
    B := C shr 16 and $FF;
    
    Min := MinIntValue( [R, G, B] );
    V   := MaxIntValue( [R, G, B] );
    Delta := V - Min;
    if   V =  0  then ss := 0
    else ss := Delta/V;
    if ss = 0 then hh := 0
    else begin
      if      R = V then hh := 60 * (G - B) / Delta
      else if G = V then hh := 120 + 60 * (B - R) / Delta
      else if B = V then hh := 240 + 60 * (R - G) / Delta;
      if hh < 0 then hh := hh + 360;
    end;
    S := round(ss*255);
    H := round(hh*255/360);
    if (r<160) and (g<160) and (b<160) then s:=200;
    result:=s;
end;
end.

						