sgraphutils.pas

AlphaControls是一个Delphi标准控件的集合

        end

      end;
    end
  end;

  for Y := 0 to Result.Height - 1 do begin
    S1 := Result.ScanLine[Y];
    for X := 0 to Result.Width - 1 do begin
      if Equal(CurX, BlackColor) then begin
        S1[X] := TransColor;
      end;
    end
  end;
end;


procedure DisableBmp(SrcBmp: TBitmap);
var
  Bmp, TempBmp : TBitmap;
  tc : TColor;
  tcrgb : TsRGB;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.Assign(SrcBmp);
    Bmp.PixelFormat := pf24bit;
    tc := Bmp.Canvas.Pixels[0, Bmp.Height - 1];
    tcrgb.R := GetRValue(tc);
    tcrgb.G := GetGValue(tc);
    tcrgb.B := GetBValue(tc);
    BWBmp(Bmp, 100); // ??? Want to make more universal ???
    TempBmp := CreateDisBitmap(Bmp, tcrgb);
    try
//      SrcBmp.Assign(Bmp);
      SrcBmp.Assign(TempBmp);
    finally
      FreeAndNil(TempBmp);
    end;
  finally
    FreeAndNil(Bmp);
  end;
end;

procedure DisBmpColor(SrcBmp: TBitmap; Color : TColor);
var
  Bmp, TempBmp : TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    Bmp.Assign(SrcBmp);
    Bmp.PixelFormat := pf24bit;
    BWBmp(Bmp, 500);
    TempBmp := CreateDisabledBitmapEx(Bmp, ColorToRGB(clBlack), ColorToRGB(Color), clWhite, ColorToRGB(clGray), True);
    try
      SrcBmp.Assign(TempBmp);
    finally
      FreeAndNil(TempBmp);
    end;
  finally
    FreeAndNil(Bmp);
  end;
end;

procedure MonoBmp(SrcBmp: TBitmap);
var
  S1 : PRGBArray;
  X, Y, w, h: Integer;
  BlackColor : TsRGB;
begin
  BlackColor.R := 0;
  BlackColor.G := 0;
  BlackColor.B := 0;
  h := SrcBmp.Height - 1;
  w := SrcBmp.Width - 1;

  for Y := 0 to h do begin
    S1 := SrcBmp.ScanLine[Y];
    for X := 0 to w do begin
      if S1[X].R + S1[X].G + S1[X].B <> 765 then begin
        S1[X] := BlackColor;
      end;
    end
  end;
end;

procedure BWBmp(SrcBmp: TBitmap; Delta : integer);
var
  S1 : PRGBArray;
  X, Y: Integer;
  d : integer;
  h, w : integer;
begin
  d := 65536 * Delta;
  h := SrcBmp.Height - 1;
  w := SrcBmp.Width - 1;
  for Y := 0 to h do begin
    S1 := SrcBmp.ScanLine[Y];
    for X := 0 to w do begin
      if S1[X].R * S1[X].G * S1[X].B < d then begin
        S1[X].R := 0;
        S1[X].G := 0;
        S1[X].B := 0;
      end
      else begin
        S1[X].R := 255;
        S1[X].G := 255;
        S1[X].B := 255;
      end;
    end
  end;
end;

procedure BorderByMask(SrcBmp, MskBmp: TBitmap; ColorTop, ColorBottom: TsColor);
var
  S1, S2, S2t, S2b : PRGBArray;
  {l, r, }t, b : boolean;
  X, Y, sw, sh: Integer;
  function BlackPoint(c: TsRGB) : boolean;
  begin
    Result := c.R + c.G + c.B = 0;
  end;
begin
  S2t := nil;
  S2b := nil;
  sh := SrcBmp.Height - 1;
  sw := SrcBmp.Width - 1;
  if SrcBmp.Height <> MskBmp.Height then Exit;
  if SrcBmp.Width <> MskBmp.Width then Exit;
  if SrcBmp.Height < 1 then Exit;
  if SrcBmp.Width < 1 then Exit;
  for Y := 0 to sh do begin
    S1 := SrcBmp.ScanLine[Y];
    S2 := MskBmp.ScanLine[Y];
    if Y > 0 then begin
      S2t := MskBmp.ScanLine[Y - 1];
      t := True;
    end else t := False;
    if Y < SrcBmp.Height - 1 then begin
      S2B := MskBmp.ScanLine[Y + 1];
      b := True;
    end else b := False;

    for X := 0 to sw do begin
      if BlackPoint(S2[X]) then begin
        if ((X > 0) and not BlackPoint(S2[X - 1])) or (X = 0) or (t and not BlackPoint(S2t[X])) or not t then begin
          S1[X].R := ColorTop.R;
          S1[X].G := ColorTop.G;
          S1[X].B := ColorTop.B;
        end
        else
        if ((X < SrcBmp.Width - 1) and not BlackPoint(S2[X + 1])) or (X = SrcBmp.Width - 1) or (b and not BlackPoint(S2b[X])) or not b then begin
          S1[X].R := ColorBottom.R;
          S1[X].G := ColorBottom.G;
          S1[X].B := ColorBottom.B;
        end;
      end;
    end
  end;
end;

procedure FillDC(DC: hWnd; aRect: TRect; Color: TColor);
var
  OldBrush, NewBrush : hBrush;
  SavedDC : hWnd;
begin
  SavedDC := SaveDC(DC);
  NewBrush := CreateSolidBrush(Color);
  OldBrush := SelectObject(dc, NewBrush);
  try
    FillRect(DC, aRect, NewBrush);
  finally
    SelectObject(dc, OldBrush);
    DeleteObject(NewBrush);
    RestoreDC(DC, SavedDC);
  end;
end;

procedure GrayScale(Bmp: TBitmap);
var
  p : PByteArray;
  Gray, x, y, w, h : integer;
begin
  h := Bmp.Height - 1;
  w := Bmp.Width - 1;
  for y := 0 to h do begin
    p := Bmp.scanline[y];
    for x := 0 to w do begin
      Gray := (p[x * 3] + p[x * 3 + 1] + p[x * 3 + 2]) div 3;
      p[x * 3 + 0] := Gray;
      p[x * 3 + 1] := Gray;
      p[x * 3 + 2] := Gray;
    end;
  end;
end;

procedure GrayScaleTrans(Bmp: TBitmap; TransColor : TsColor);
var
  S1 : PRGBArray;
  Gray, x, y, w, h : integer;
begin
  h := Bmp.Height - 1;
  w := Bmp.Width - 1;
  for Y := 0 to h do begin
    S1 := Bmp.ScanLine[Y];
    for X := 0 to w do begin
      if (S1[X].B <> TransColor.B) or (S1[X].G <> TransColor.G) or (S1[X].R <> TransColor.R) then begin
        Gray := (S1[X].R + S1[X].G + S1[X].B) div 3;
        S1[X].R := Gray;
        S1[X].G := Gray;
        S1[X].B := Gray;
      end;
    end
  end;
end;

procedure BeveledBorder(DC: HDC; ColorTop, ColorBottom, Color: TColor; aRect: TRect; Width : integer; Bevel: TsBorderStyle; Soft : boolean);
var
//  i, w : integer;
  R: TRect;
  Color1, Color2 : TColor;
  TopBevel, BottomBevel: TsBorderStyle;
  procedure DrawRect; begin
    // Left line
    BeveledLine(dc, Color1, Color,
                Point(R.Left, R.Bottom - 1),
                Point(R.Left, R.Top),
                Width,
                TopBevel,
                sdLeft);
    // Top line
    BeveledLine(dc, Color1, Color,
                Point(R.Left, R.Top),
                Point(R.Right, R.Top),
                Width,
                TopBevel,
                sdTop);
    // Right line
    BeveledLine(dc, Color2, Color,
                Point(R.Right - 1, R.Top + 1),
                Point(R.Right - 1, R.Bottom - 1),
                Width,
                BottomBevel,
                sdRight);
    // Bottom Line
    BeveledLine(dc, Color2, Color,
                Point(R.Right - 1, R.Bottom - 1),
                Point(R.Left, R.Bottom - 1),
                Width,
                BottomBevel,
                sdBottom);
  end;
  procedure DrawRectSharp; begin
    // Left line
    SharpenLine(dc, Color1,
                Point(R.Left, R.Bottom - 1),
                Point(R.Left, R.Top),
                Width,
                TopBevel,
                sdLeft);
    // Top line
    SharpenLine(dc, Color1,
                Point(R.Left, R.Top),
                Point(R.Right, R.Top),
                Width,
                TopBevel,
                sdTop);
    // Right line
    SharpenLine(dc, Color2, 
                Point(R.Right - 1, R.Top + 1),
                Point(R.Right - 1, R.Bottom - 1),
                Width,
                BottomBevel,
                sdRight);
    // Bottom Line
    SharpenLine(dc, Color2,
                Point(R.Right - 1, R.Bottom - 1),
                Point(R.Left, R.Bottom - 1),
                Width,
                BottomBevel,
                sdBottom);
  end;
begin
  Color1 := ColorTop;
  Color2 := ColorBottom;
  R := aRect;
  Case Bevel of
    bsFlat1 : begin
      Color1 := ColorTop;
      Color2 := Color1;
      TopBevel := bsFlat1;
      BottomBevel := bsFlat1;
    end;
    bsFlat2 : begin
      Color1 := ColorBottom;
      Color2 := Color1;
      TopBevel := bsFlat2;
      BottomBevel := bsFlat2;
    end;
    sConst.bsRaised: begin
      TopBevel := sConst.bsRaised;
      BottomBevel := sConst.bsLowered;
    end;
    sConst.bsLowered: begin
      Color1 := ColorBottom;
      Color2 := ColorTop;
      BottomBevel := sConst.bsRaised;
      TopBevel := sConst.bsLowered;
    end;
  end;
  if not Soft then begin
    DrawRectSharp;
  end
  else begin
    DrawRect;
  end;
end;

procedure DrawLine(dc: HDC; Point1, Point2 : TPoint; LineColor: TColor);
var
  NewPen, OldPen : hPen;
  OldBrush : hBrush;
  SavedDC : hWnd;
begin
  SavedDC := SaveDC(DC);
  if SavedDC = 0 then Exit;
  NewPen := CreatePen(PS_SOLID, 1, LineColor);
  OldPen := SelectObject(dc, NewPen);
  OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
  try
    MoveToEx(dc, Point1.x, Point1.y, nil);
    LineTo(dc, Point2.x, Point2.y);
  finally
    SelectObject(dc, OldPen);
    SelectObject(dc, OldBrush);
    DeleteObject(NewPen);
    RestoreDC(DC, SavedDC);
  end;
end;

procedure SharpenLine(DC: HDC; ColorLine: TColor; P1, P2: TPoint; Width : integer; Bevel: TsBorderStyle; Side: TsSide);
var
  i: integer;
  pP1, pP2: TPoint;
  NewColor : TColor;
  SavedDC : hWnd;
  procedure ChangeCoord; begin
    case Side of
      sdLeft:   begin inc(pP1.x); dec(pP1.y); inc(pP2.x); inc(pP2.y); end;
      sdTop:    begin inc(pP1.x); inc(pP1.y); dec(pP2.x); inc(pP2.y); end;
      sdRight:  begin dec(pP1.x); inc(pP1.y); dec(pP2.x); dec(pP2.y); end;
      sdBottom: begin dec(pP1.x); dec(pP1.y); inc(pP2.x); dec(pP2.y); end;
    end;
  end;
begin
  SavedDC := SaveDC(DC);
  if SavedDC = 0 then Exit;

  try
    NewColor := ColorLine;
    pP1 := P1;
    pP2 := P2;

    Case Bevel of
      bsFlat1, bsFlat2 : begin
        for i := 0 to Width - 1 do begin // Raised
          DrawLine(dc, pP1, pP2, NewColor);
          ChangeCoord;
        end;
      end;
      sConst.bsRaised: begin
        if Width > 1 then begin
          NewColor := ColorLine;
          for i := 0 to Width - 1 do begin
            DrawLine(dc, pP1, pP2, NewColor);
            ChangeCoord;
          end;
        end
        else begin
          NewColor := ColorLine;
          DrawLine(dc, pP1, pP2, NewColor);