USrv.pas

   1 Unit USrv;
   2
   3 interface
   4 uses Windows, Classes, Graphics, Controls, Messages, Dialogs,
   5      SysUtils;
   6
   7 const WM_GETIMAGE = WM_USER + $0429;
   8
   9 function  BitmapToRegion(Bitmap: TBitmap): HRGN;
  10 function  CopyToBitmap(Control: TControl; Bitmap: TBitmap; Anyway: boolean): boolean;
  11 procedure CopyParentImage(Control: TControl; Dest: TCanvas);
  12 procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect;
  13                        dwROP: dword); overload;
  14 procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer;
  15                        dwROP: dword); overload;
  16 procedure AjustBitmap(const M: TBitmap; S, C: TColor);
  17 procedure FadeBitmap(const M: TBitmap; C: TColor; D: byte);
  18 function  IncColor(C: TColor; D: integer): TColor;
  19
  20 implementation
  21
  22 function BitmapToRegion(Bitmap: TBitmap): HRGN;
  23 var
  24    X, Y: Integer;
  25  XStart: Integer;
  26  TransC: TColor;
  27       R: HRGN;
  28 begin
  29    Result := 0;
  30    with Bitmap do begin
  31       TransC := Canvas.Pixels[0, 0];
  32       for Y := 0 to Height - 1 do begin
  33          X := 0;
  34          while X < Width do begin
  35             while (X < Width) and (Canvas.Pixels[X, Y]  = TransC) do Inc(X);
  36             if X >= Width then Break;
  37             XStart := X;
  38             while (X < Width) and (Canvas.Pixels[X, Y] <> TransC) do Inc(X);
  39             R := CreateRectRgn(XStart, Y, X, Y + 1);
  40             if Result = 0 then Result := R
  41                           else begin
  42                CombineRgn(Result, Result, R, RGN_OR);
  43                DeleteObject(R);
  44             end;
  45          end;
  46       end;
  47    end;
  48 end;
  49
  50 function CopyToBitmap;
  51 var x, y: integer;
  52 begin
  53    Result := False;
  54    if Control = nil then exit;
  55    x := BitMap.Width  - 2;
  56    y := BitMap.Height - 2;
  57    if (Anyway) or
  58       (x + 2 <> Control.Width) or
  59       (y + 2 <> Control.Height) or
  60       (BitMap.Canvas.Pixels[x, y] = $FFFFFF) or
  61       (BitMap.Canvas.Pixels[x, y] = $000000) then begin
  62        BitMap.Width  := Control.Width;
  63        BitMap.Height := Control.Height;
  64        CopyParentImage(Control, BitMap.Canvas);
  65        Result := True;
  66    end;
  67 end;
  68
  69 type
  70   TParentControl = class(TWinControl);
  71
  72 procedure CopyParentImage(Control: TControl; Dest: TCanvas);
  73 var
  74   I, Count, X, Y, SaveIndex: Integer;
  75   DC: HDC;
  76   R, SelfR, CtlR: TRect;
  77 begin
  78   if (Control = nil) or (Control.Parent = nil) then Exit;
  79   Count := Control.Parent.ControlCount;
  80   DC := Dest.Handle;
  81   with Control.Parent do ControlState := ControlState + [csPaintCopy];
  82   try
  83     with Control do begin
  84       SelfR := Bounds(Left, Top, Width, Height);
  85       X := -Left; Y := -Top;
  86     end;
  87     { Copy parent control image }
  88     SaveIndex := SaveDC(DC);
  89     try
  90        if TParentControl(Control.Parent).Perform(
  91           WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin
  92           SetViewportOrgEx(DC, X, Y, nil);
  93           IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
  94                             Control.Parent.ClientHeight);
  95           with TParentControl(Control.Parent) do begin
  96              Perform(WM_ERASEBKGND, DC, 0);
  97              PaintWindow(DC);
  98           end;
  99        end;
 100     finally
 101       RestoreDC(DC, SaveIndex);
 102     end;
 103     { Copy images of graphic controls }
 104     for I := 0 to Count - 1 do begin
 105       if Control.Parent.Controls[I] = Control then continue
 106       else if (Control.Parent.Controls[I] <> nil) and
 107         (Control.Parent.Controls[I] is TGraphicControl) then
 108       begin
 109         with TGraphicControl(Control.Parent.Controls[I]) do begin
 110           CtlR := Bounds(Left, Top, Width, Height);
 111           if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
 112             ControlState := ControlState + [csPaintCopy];
 113             SaveIndex := SaveDC(DC);
 114             try
 115               if Perform(
 116                  WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin
 117 {                 SaveIndex := SaveDC(DC);}
 118                  SetViewportOrgEx(DC, Left + X, Top + Y, nil);
 119                  IntersectClipRect(DC, 0, 0, Width, Height);
 120                  Perform(WM_PAINT, DC, 0);
 121               end;
 122             finally
 123               RestoreDC(DC, SaveIndex);
 124               ControlState := ControlState - [csPaintCopy];
 125             end;
 126           end;
 127         end;
 128       end;
 129     end;
 130   finally
 131     with Control.Parent do ControlState := ControlState - [csPaintCopy];
 132   end;
 133 end;
 134
 135 procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect;
 136                        dwROP: dword); overload;
 137 begin
 138    RestoreImage(DestDC, SrcBitmap, r.Left, r.Top,
 139                 r.Right - r.Left, r.Bottom - r.Top, dwROP);
 140 end;
 141
 142 procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer;
 143                        dwROP: dword); overload;
 144 var x, y: integer;
 145 begin
 146    x := l + w div 2;
 147    y := t + h div 2;
 148    if (SrcBitmap.Canvas.Pixels[x, y] <> $FFFFFF) and
 149       (SrcBitMap.Canvas.Pixels[x, y] <> $000000) then begin
 150       x := l;
 151       y := t;
 152       if y + h > SrcBitMap.Height then begin
 153          y := SrcBitMap.Height - h;
 154       end;
 155       bitblt(DestDC, l, t, w, h,
 156              SrcBitMap.Canvas.Handle, x, y, dwROP);
 157    end;
 158 end;
 159
 160  procedure SplitColor(C: TColor; var r, g, b: integer);
 161  begin
 162     b := (c and $FF0000) shr 16;
 163     g := (c and $00FF00) shr 08;
 164     r := (c and $0000FF) shr 00;
 165  end;
 166
 167 procedure AjustBitmap;
 168 var i, j: integer;
 169        t: TBitmap;
 170        r,
 171        g,
 172        b,
 173       r2,
 174       g2,
 175       b2: integer;
 176        p: PRGBTriple;
 177
 178  function CalcColor(c1, c2, c3: integer): integer;
 179  begin
 180    if c1 = c3 then begin
 181       Result := c2;
 182       exit;
 183    end;
 184
 185    if c1 = 0 then begin
 186       Result := 0;
 187       exit;
 188    end;
 189
 190 {   Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3);
 191    exit;}
 192
 193    Result := c1 * c2 div c3;
 194    if c2 = 0 then Result := c1 * 150 div 255;
 195    if Result > 255 then Result := 255;
 196    if Result <  50 then Result :=  Result + 50;
 197 {   exit;
 198    a  := trunc(x1 * 3);
 199    a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3);
 200    a := 255 * 255 - 4 * a;
 201    try
 202       x1 := Trunc((255 - sqrt(a)) / 2);
 203       x2 := Trunc((255 + sqrt(a)) / 2);
 204       if x1 > x2 then Result := Trunc(x1)
 205                  else Result := Trunc(x2);
 206    except
 207       Result := 0;
 208    end;}
 209  end;
 210
 211 begin
 212    if s         = c then exit;
 213    if m.Width   = 0 then exit;
 214    if m.Height  = 0 then exit;
 215    t := TBitmap.Create;
 216    m.PixelFormat := pf24bit;
 217    t.Assign(m);
 218    SplitColor(ColorToRGB(s), r, g, b);
 219    if r = 0 then r := 1;
 220    if g = 0 then g := 1;
 221    if b = 0 then b := 1;
 222    SplitColor(ColorToRGB(c), r2, g2, b2);
 223    for j := 0 to t.Height - 1 do begin
 224       p := t.scanline[j];
 225       for i := 0 to t.Width - 1 do begin
 226          p.rgbtRed   := CalcColor(p.rgbtRed,   r2, r);
 227          p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g);
 228          p.rgbtBlue  := CalcColor(p.rgbtBlue,  b2, b);
 229          inc(p);
 230       end;
 231    end;
 232    m.Assign(t);
 233    t.Free;
 234 end;
 235
 236 procedure FadeBitmap;
 237 var i, j: integer;
 238        t: TBitmap;
 239        r,
 240        g,
 241        b: integer;
 242        p: PRGBTriple;
 243
 244  function CalcColor(o: byte; c: byte; b: byte): byte;
 245  var d: byte;
 246  begin
 247     Result := c;
 248     if o > c then begin
 249        d := $FF - c;
 250        if d > b then d := b;
 251        Result := c + c * d div 255;
 252     end else
 253     if o < c then begin
 254        d := c;
 255        if d > b then d := b;
 256        Result := c - c * d div 255;
 257     end;
 258  end;
 259
 260 begin
 261    if m.Width   = 0 then exit;
 262    if m.Height  = 0 then exit;
 263    t := TBitmap.Create;
 264    m.PixelFormat := pf24bit;
 265    t.Assign(m);
 266    SplitColor(ColorToRGB(c), r, g, b);
 267    if r = 0 then r := 1;
 268    if g = 0 then g := 1;
 269    if b = 0 then b := 1;
 270    for j := 0 to t.Height - 1 do begin
 271       p := t.scanline[j];
 272       for i := 0 to t.Width - 1 do begin
 273          p.rgbtRed   := CalcColor(p.rgbtRed,   r, d);
 274          p.rgbtGreen := CalcColor(p.rgbtGreen, g, d);
 275          p.rgbtBlue  := CalcColor(p.rgbtBlue,  b, d);
 276          inc(p);
 277       end;
 278    end;
 279    m.Assign(t);
 280    t.Free;
 281 end;
 282
 283 function IncColor;
 284 var T: TColor;
 285     P: PRGBTriple;
 286 begin
 287    T := ColorToRGB(C);
 288    p := @T;
 289    if D > 0 then begin
 290       if p.rgbtBlue  < 255 - D then p.rgbtBlue  := p.rgbtBlue  + D else p.rgbtBlue  := 255;
 291       if p.rgbtRed   < 255 - D then p.rgbtRed   := p.rgbtRed   + D else p.rgbtRed   := 255;
 292       if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255;
 293    end else begin
 294       if p.rgbtBlue  >       D then p.rgbtBlue  := p.rgbtBlue  - D else p.rgbtBlue  := 000;
 295       if p.rgbtRed   >       D then p.rgbtRed   := p.rgbtRed   - D else p.rgbtRed   := 000;
 296       if p.rgbtGreen >       D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000;
 297    end;
 298    Result := T;
 299 end;
 300
 301 end.