dib.pas

为delphi量身打造的 direct x控件代码

  begin
    i := 0;

    for y:=0 to Height-1 do
    begin
      SrcP := Temp.ScanLine[y];
      DestP := ScanLine[y];

      for x:=0 to Width-1 do
      begin
        case Temp.BitCount of
          1 : begin
                i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
              end;
          4 : begin
                i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
              end;
          8 : begin
                i := PByte(SrcP)^;
                Inc(PByte(SrcP));
              end;
        end;

        case BitCount of
          1 : begin
                P := @PArrayByte(DestP)[X shr 3];
                P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
              end;
          4 : begin
                P := @PArrayByte(DestP)[X shr 1];
                P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
              end;
          8 : begin
                PByte(DestP)^ := i;
                Inc(PByte(DestP));
              end;
        end;
      end;
    end;
  end;

  procedure PaletteToRGB_or_RGBToRGB;
  var
    x, y: Integer;
    SrcP, DestP: Pointer;
    cR, cG, cB: Byte;
  begin
    cR := 0;
    cG := 0;
    cB := 0;

    for y:=0 to Height-1 do
    begin
      SrcP := Temp.ScanLine[y];
      DestP := ScanLine[y];

      for x:=0 to Width-1 do
      begin
        case Temp.BitCount of
          1 : begin
                with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
                begin
                  cR := rgbRed;
                  cG := rgbGreen;
                  cB := rgbBlue;
                end;
              end;
          4 : begin
                with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
                begin
                  cR := rgbRed;
                  cG := rgbGreen;
                  cB := rgbBlue;
                end;
              end;
          8 : begin
                with Temp.ColorTable[PByte(SrcP)^] do
                begin
                  cR := rgbRed;
                  cG := rgbGreen;
                  cB := rgbBlue;
                end;
                Inc(PByte(SrcP));
              end;
          16: begin
                pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
                Inc(PWord(SrcP));
              end;
          24: begin
                with PBGR(SrcP)^ do
                begin
                  cR := R;
                  cG := G;
                  cB := B;
                end;

                Inc(PBGR(SrcP));
              end;
          32: begin
                pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
                Inc(PDWORD(SrcP));
              end;
        end;

        case BitCount of
          16: begin
                PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
                Inc(PWord(DestP));
              end;
          24: begin
                with PBGR(DestP)^ do
                begin
                  R := cR;
                  G := cG;
                  B := cB;
                end;
                Inc(PBGR(DestP));
              end;
          32: begin
                PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
                Inc(PDWORD(DestP));
              end;
        end;
      end;
    end;
  end;

begin
  if Size=0 then exit;

  Temp := TDIB.Create;
  try
    Temp.Assign(Self);
    SetSize(Temp.Width, Temp.Height, ABitCount);

    if FImage=Temp.FImage then Exit;

    if (Temp.BitCount<=8) and (BitCount<=8) then
    begin
      {  The image is converted from the palette color image into the palette color image.  }
      if Temp.BitCount<=BitCount then
      begin
        PaletteToPalette_Inc;
      end else
      begin
        case BitCount of
          1: begin
               ColorTable[0] := RGBQuad(0, 0, 0);
               ColorTable[1] := RGBQuad(255, 255, 255);
             end;
          4: CreateHalftonePalette(1, 2, 1);
          8: CreateHalftonePalette(3, 3, 2);
        end;
        UpdatePalette;

        Canvas.Draw(0, 0, Temp);
      end;
    end else
    if (Temp.BitCount<=8) and (BitCount>8) then
    begin
      {  The image is converted from the palette color image into the rgb color image.  }
      PaletteToRGB_or_RGBToRGB;
    end else
    if (Temp.BitCount>8) and (BitCount<=8) then
    begin
      {  The image is converted from the rgb color image into the palette color image.  }
      case BitCount of
        1: begin
             ColorTable[0] := RGBQuad(0, 0, 0);
             ColorTable[1] := RGBQuad(255, 255, 255);
           end;
        4: CreateHalftonePalette(1, 2, 1);
        8: CreateHalftonePalette(3, 3, 2);
      end;
      UpdatePalette;

      Canvas.Draw(0, 0, Temp);
    end else
    if (Temp.BitCount>8) and (BitCount>8) then
    begin
      {  The image is converted from the rgb color image into the rgb color image.  }
      PaletteToRGB_or_RGBToRGB;
    end;
  finally
    Temp.Free;
  end;
end;

{  Special effect  }

procedure TDIB.StartProgress(const Name: string);
begin
  FProgressName := Name;
  FProgressOld := 0;
  FProgressOldTime := GetTickCount;
  FProgressY := 0;
  FProgressOldY := 0;
  Progress(Self, psStarting, 0, False, Rect(0, 0, Width, Height), FProgressName);
end;

procedure TDIB.EndProgress;
begin
  Progress(Self, psEnding, 100, True, Rect(0, FProgressOldY, Width, Height), FProgressName);
end;

procedure TDIB.UpdateProgress(PercentY: Integer);
var
  Redraw: Boolean;
  Percent: DWORD;
begin
  Redraw := (GetTickCount-FProgressOldTime>200) and (FProgressY-FProgressOldY>32) and
    (((Height div 3>Integer(FProgressY)) and (FProgressOldY=0)) or (FProgressOldY<>0));

  Percent := PercentY*100 div Height;

  if (Percent<>FProgressOld) or (Redraw) then
  begin
    Progress(Self, psRunning, Percent, Redraw,
      Rect(0, FProgressOldY, Width, FProgressY), FProgressName);
    if Redraw then
    begin
      FProgressOldY := FProgressY;
      FProgressOldTime := GetTickCount;
    end;

    FProgressOld := Percent;
  end;

  Inc(FProgressY);
end;

procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
type
  TAve = record
    cR, cG, cB: DWORD;
    c: DWORD;
  end;
  TArrayAve = array[0..0] of TAve;

var
  Temp: TDIB;

  procedure AddAverage(Y, XCount: Integer; var Ave: TArrayAve);
  var
    X: Integer;
    SrcP: Pointer;
    AveP: ^TAve;
    R, G, B: Byte;
  begin
    case Temp.BitCount of
      1 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
              begin
                Inc(cR, rgbRed);
                Inc(cG, rgbGreen);
                Inc(cB, rgbBlue);
                Inc(c);
              end;
              Inc(AveP);
            end;
          end;
      4 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
              begin
                Inc(cR, rgbRed);
                Inc(cG, rgbGreen);
                Inc(cB, rgbBlue);
                Inc(c);
              end;
              Inc(AveP);
            end;
          end;
      8 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[PByte(SrcP)^], AveP^ do
              begin
                Inc(cR, rgbRed);
                Inc(cG, rgbGreen);
                Inc(cB, rgbBlue);
                Inc(c);
              end;
              Inc(PByte(SrcP));
              Inc(AveP);
            end;
          end;
      16: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Inc(cR, R);
                Inc(cG, G);
                Inc(cB, B);
                Inc(c);
              end;
              Inc(PWord(SrcP));
              Inc(AveP);
            end;
          end;
      24: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with PBGR(SrcP)^, AveP^ do
              begin
                Inc(cR, R);
                Inc(cG, G);
                Inc(cB, B);
                Inc(c);
              end;
              Inc(PBGR(SrcP));
              Inc(AveP);
            end;
          end;
      32: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Inc(cR, R);
                Inc(cG, G);
                Inc(cB, B);
                Inc(c);
              end;
              Inc(PDWORD(SrcP));
              Inc(AveP);
            end;
          end;
    end;
  end;

  procedure DeleteAverage(Y, XCount: Integer; var Ave: TArrayAve);
  var
    X: Integer;
    SrcP: Pointer;
    AveP: ^TAve;
    R, G, B: Byte;
  begin
    case Temp.BitCount of
      1 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
              begin
                Dec(cR, rgbRed);
                Dec(cG, rgbGreen);
                Dec(cB, rgbBlue);
                Dec(c);
              end;
              Inc(AveP);
            end;
          end;
      4 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
              begin
                Dec(cR, rgbRed);
                Dec(cG, rgbGreen);
                Dec(cB, rgbBlue);
                Dec(c);
              end;
              Inc(AveP);
            end;
          end;
      8 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[PByte(SrcP)^], AveP^ do
              begin
                Dec(cR, rgbRed);
                Dec(cG, rgbGreen);
                Dec(cB, rgbBlue);
                Dec(c);
              end;
              Inc(PByte(SrcP));
              Inc(AveP);
            end;
          end;
      16: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Dec(cR, R);
                Dec(cG, G);
                Dec(cB, B);
                Dec(c);
              end;
              Inc(PWord(SrcP));
              Inc(AveP);
            end;
          end;
      24: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with PBGR(SrcP)^, AveP^ do
              begin
                Dec(cR, R);
                Dec(cG, G);
                Dec(cB, B);
                Dec(c);
              end;
              Inc(PBGR(SrcP));
              Inc(AveP);
            end;
          end;
      32: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Dec(cR, R);
                Dec(cG, G);
                Dec(cB, B);
                Dec(c);
              end;
              Inc(PDWORD(SrcP));
              Inc(AveP);
            end;
          end;
    end;
  end;

  procedure Blur_Radius_Other;
  var
    FirstX, LastX, FirstX2, LastX2, FirstY, LastY: Integer;
    x, y, x2, y2, jx, jy: Integer;
    Ave: TAve;
    AveX: ^TArrayAve;
    DestP: Pointer;
    P: PByte;
  begin
    GetMem(AveX, Width*SizeOf(TAve));
    try
      FillChar(AveX^, Width*SizeOf(TAve), 0);

      FirstX2 := -1;
      LastX2 := -1;
      FirstY := -1;
      LastY := -1;

      x := 0;
      for x2:=-Radius to Radius do
      begin
        jx := x+x2;
        if (jx>=0) and (jx<Width) then
        begin
          if FirstX2=-1 then FirstX2 := jx;
          if LastX2<jx then LastX2 := jx;
        end;
      end;

      y := 0;
      for y2:=-Radius to Radius do
      begin
        jy := y+y2;
        if (jy>=0) and (jy<Height) then
        begin
          if FirstY=-1 then FirstY := jy