lbmorphutils.pas

天涯進銷存系統

unit LBMorphUtils;

{$P+,S-,W-,R-}

interface

  Uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  ExtCtrls, CommCtrl;

  procedure CopyParentImage(Control: TControl; Dest: TCanvas);
  procedure CopyParentImage1(Control: TControl; Dest: TCanvas);
  procedure Frm3D(Canvas: TCanvas; Rect: TRect; TopColor, BottomColor: TColor;
                  Width: Integer);
  function RGBChange(A: Longint; Rx, Gx, Bx: ShortInt): Longint;
  procedure RndFrm3D(Cnvs: TCanvas; C1,C2: TColor; R: TRect;W: Integer);
  procedure RndRectFrm3D(Cnvs: TCanvas; Rct: TRect; c1, c2: TColor;
                            R, W: Integer);

  function MiddleColor(color1, color2: TColor): Tcolor;

  procedure GetScreenImage(X, Y: Integer; B: TBitMap);

implementation

type
  TParentControl = class(TWinControl);
  TRGB = record
    R, G, B, A: Byte;
  end;

procedure CopyParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if Control.Parent = nil then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  X := -Control.Left; Y := -Control.Top;
  // Copy parent control image
  SaveIndex := SaveDC(DC);
  SetViewportOrgEx(DC, X, Y, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
  Control.Parent.ClientHeight);
  TParentControl(Control.Parent).PaintWindow(DC);
  RestoreDC(DC, SaveIndex);
  // Copy images of graphic controls
  for I := 0 to Count - 1 do
  begin
    if (Control.Parent.Controls[I] <> nil) and
      not (Control.Parent.Controls[I] is TWinControl) then
    begin
      if Control.Parent.Controls[I] = Control then Break;
      with Control.Parent.Controls[I] do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_PAINT, DC, 0);
          RestoreDC(DC, SaveIndex);
        end;
      end;
    end;
  end;
end;


procedure CopyParentImage1(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if Control.Parent = nil then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  X := -Control.Left; Y := -Control.Top;
  // Copy parent control image
  SaveIndex := SaveDC(DC);
  SetViewportOrgEx(DC, X, Y, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
  Control.Parent.ClientHeight);
  TParentControl(Control.Parent).PaintWindow(DC);
  RestoreDC(DC, SaveIndex);
  // Copy images of graphic controls
  for I := 0 to Count - 1 do
  begin
    if (Control.Parent.Controls[I] <> nil) and
      not (Control.Parent.Controls[I] is TWinControl) then
    begin
      if Control.Parent.Controls[I] = Control then Break;
      with Control.Parent.Controls[I] do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_PAINT, DC, 0);
          RestoreDC(DC, SaveIndex);
        end;
      end;
    end;
  end;

  // Copy images of TCustomControls
  for I := 0 to Count - 1 do
  begin
    if (Control.Parent.Controls[I] <> nil) and
       (Control.Parent.Controls[I] is TCustomControl) then
    begin
      if Control.Parent.Controls[I] = Control then Break;
      with (Control.Parent.Controls[I] as TCustomControl) do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if Bool(IntersectRect(R, SelfR, CtlR)) and Visible
        then
          PaintTo(Dest.Handle, X + Left, Y + Top);
      end;
    end;
  end;
end;


procedure Frm3D(Canvas: TCanvas; Rect: TRect; TopColor, BottomColor: TColor;
  Width: Integer);

  procedure DoRect;
  var
    TopRight, BottomLeft: TPoint;
  begin
    with Canvas, Rect do
    begin
      TopRight.X := Right;
      TopRight.Y := Top;
      BottomLeft.X := Left;
      BottomLeft.Y := Bottom;
      Pen.Color := TopColor;
      PolyLine([BottomLeft, TopLeft, TopRight]);
      Pen.Color := BottomColor;
      Dec(BottomLeft.X);
      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom); Dec(Rect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(Rect, -1, -1);
  end;
  Inc(Rect.Bottom); Inc(Rect.Right);
end;

procedure RndFrm3D;
var
  a, b, c: LongInt;
  x1, y1, x2, y2: Integer;
begin
  a := (R.Right - R.Left) div 2;
  b := (R.Bottom - R.Top) div 2;
  if a >= b then
  begin
    c := Round(Sqrt(Sqr(a) - Sqr(b))); // excentris of ellipse
    c := a - c;
    x1 := R.Left + c div 3; y1 := R.Top + (R.Bottom - R.Top) div 2 + c - c div 3;
    x2 := R.Right - c div 3; y2 := R.Top + (R.Bottom - R.Top) div 2 - c + c div 3;
  end
  else
  begin
    c := Round(Sqrt(Sqr(b) - Sqr(a))); // excentris of ellipse
    c := b - c;
    x1 := R.Left + c div 3; y1 := R.Bottom  - c div 3;
    x2 := R.Right - c div 3; y2 := R.Top + c div 3;
  end;
  with Cnvs do
  begin
    Pen.Width := W;
    Pen.Color := C2;
    Arc(R.Left,R.Top,R.Right,R.Bottom,x1,y1,x2,y2);
    Pen.Color := C1;
    Arc(R.Left,R.Top,R.Right,R.Bottom,x2,y2,x1,y1);
  end;
end;


procedure RndRectFrm3D(Cnvs: TCanvas; Rct: TRect; c1, c2: TColor;
                            R, W: Integer);
var
  x1, y1, x2, y2: Integer;
  R1: Integer;
begin
  if W mod 2 = 0
  then
    begin
      x1 := Rct.Left + 1;
      y1 := Rct.Top + 1;
    end
  else
    begin
      x1 := Rct.Left;
      y1 := Rct.Top;
    end;
  x2 := Rct.Right - 1;
  y2 := Rct.Bottom - 1;
  R1 := R div 2;
  if R mod 2 <> 0 then Dec(R);
  with Cnvs do
  begin
    Pen.Width := W;
    if c2 <> clNone
    then
      begin
        Pen.Color := c2;
        MoveTo(x2, y1 + R1); LineTo(x2,y2 - R1);
        MoveTo(x1 + R1,y2); LineTo(x2 - R1,y2);
        Arc(x2+1,y2+1,x2-R,y2-R,x2-R1,y2,x2,y2-R1-1);
        Arc(x1,y2+1,x1+R+1,y2-R-1,x1,y2-R1,x1+R1,y2);
      end;
    if c1 <> clNone
    then
      begin
        Pen.Color := c1;
        MoveTo(x1 + R1,y1); LineTo(x2 - R1,y1);
        MoveTo(x1, y1 + R1); LineTo(x1,y2 - R1);
        Arc(x1,y1,x1+R+1,y1+R+1,x1+R1,y1,x1,y1+R1);
        Arc(x2+1,y1,x2-R-1,y1+R+1,x2,y1+R1,x2 - R1 - 1,y1);
        Arc(x1,y2+1,x1+R+1,y2-R-1,x1,y2 - R1,x1,y2 - R1 div 3);
      end;
    if c2 <> clNone
    then
      begin
        Pen.Color := c2;
        Arc(x2+1,y1,x2-R-1,y1+R+1,x2,y1+R1,x2,y1+R1 div 3);
      end;
  end;
end;


function RGBChange(A: Longint; Rx, Gx, Bx: ShortInt): Longint;
var
  RGB: TRGB;
begin
  RGB := TRGB(A);
  // Change Red Part
  If Rx > 0 Then
    If RGB.R + Rx < $FF Then Inc(RGB.R, Rx) else RGB.R :=  $FF;
  If Rx < 0 Then
    If RGB.R > Abs(Rx) Then Dec(RGB.R, Abs(Rx)) else RGB.R := 0;
  // Change Green Part
  If Gx > 0 Then
    If RGB.G + Gx < $FF Then Inc(RGB.G, Gx) else RGB.G := $FF;
  If Gx < 0 Then
    If RGB.G > Abs(Gx) Then Dec(RGB.G, Abs(Gx)) else RGB.G := 0;
  // Change Blue Part
  If Bx > 0 Then
    If RGB.B + Bx < $FF Then Inc(RGB.B, Bx) else RGB.B := $FF;
  If Bx < 0 Then
    If RGB.B > Abs(Bx) Then Dec(RGB.B, Abs(Bx)) else RGB.B := 0;
  Result := Longint(RGB);
end;


function Red(Color: Tcolor): Byte;
begin
  result := GetRValue(ColorToRGB(Color));
end;

function Green(Color: Tcolor): Byte;
begin
  result := GetGValue(ColorToRGB(Color));
end;

function Blue(Color: Tcolor): Byte;
begin
  result := GetBValue(ColorToRGB(Color));
end;


function MiddleColor(color1, color2: TColor): Tcolor;

function Compose(r,g,b: integer): TColor;
begin
  Result := RGB(r,g,b);
end;

begin
  result := Compose(
    trunc((Red(Color1) + Red(Color2))/2),
    trunc((green(Color1) + green(Color2))/2),
    trunc((Blue(Color1) + Blue(Color2))/2))
end;

procedure GetScreenImage(X, Y: Integer; B: TBitMap);
var
  DC, DC1, DC2: HDC;
begin
  DC := CreateDC('DISPLAY', nil, nil, nil);
  DC1 := CreateCompatibleDC(DC);
  DC2 := CreateCompatibleBitmap(DC, B.Width, B.Height);
  SelectObject(DC1, DC2);
  BitBlt(DC1, 0, 0, B.Width, B.Height, DC, X, Y, SRCCOPY);
  StretchBlt(B.Canvas.Handle, 0, 0, B.Width, B.Height,
             DC1, 0, 0, B.Width, B.Height, SRCCOPY);
  DeleteDC(DC2);
  DeleteDC(DC1);
  DeleteDC(DC);
end;


end.