dib.pas

传奇服务端Delphi7编译必需的全部第三方控件！！！！！

destructor TPaletteManager.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

function TPaletteManager.CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
type
  TMyLogPalette = record
    palVersion: Word;
    palNumEntries: Word;
    palPalEntry: TPaletteEntries;
  end;
var
  i, ID: Integer;
  Item: TPaletteItem;
  LogPalette: TMyLogPalette;
begin
  {  Hash key making  }
  ID := ColorTableCount;
  for i:=0 to ColorTableCount-1 do
    with ColorTable[i] do
    begin
      Inc(ID, rgbRed);
      Inc(ID, rgbGreen);
      Inc(ID, rgbBlue);
    end;

  {  Does the same palette already exist?  }
  for i:=0 to FList.Count-1 do
  begin
    Item := TPaletteItem(FList.Items[i]);
    if (Item.ID=ID) and (Item.ColorTableCount=ColorTableCount) and
      CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount*SizeOf(TRGBQuad)) then
    begin
      Item.AddRef; Result := Item.Palette;
      Exit;
    end;
  end;

  {  New palette making  }
  Item := TPaletteItem.Create(FList);
  Item.ID := ID;
  Move(ColorTable, Item.ColorTable, ColorTableCount*SizeOf(TRGBQuad));
  Item.ColorTableCount := ColorTableCount;

  with LogPalette do
  begin
    palVersion := $300;
    palNumEntries := ColorTableCount;
    palPalEntry := RGBQuadsToPaletteEntries(ColorTable);
  end;

  Item.Palette := Windows.CreatePalette(PLogPalette(@LogPalette)^);
  Item.AddRef; Result := Item.Palette;
end;

procedure TPaletteManager.DeletePalette(var Palette: HPalette);
var
  i: Integer;
  Item: TPaletteItem;
begin
  if Palette=0 then Exit;

  for i:=0 to FList.Count-1 do
  begin
    Item := TPaletteItem(FList.Items[i]);
    if (Item.Palette=Palette) then
    begin
      Palette := 0;
      Item.Release;
      Exit;
    end;
  end;
end;

var
  FPaletteManager: TPaletteManager;

function PaletteManager: TPaletteManager;
begin
  if FPaletteManager=nil then
    FPaletteManager := TPaletteManager.Create;
  Result := FPaletteManager;
end;

constructor TDIBSharedImage.Create;
begin
  inherited Create;
  FMemoryImage := True;
  SetColorTable(GreyscaleColorTable);
  FColorTable := GreyscaleColorTable;
  FPixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;

procedure TDIBSharedImage.NewImage(AWidth, AHeight, ABitCount: Integer;
  const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
var
  InfoOfs: Integer;
  UsePixelFormat: Boolean;
begin
  Create;

  {  Pixel format check  }
  case ABitCount of
    1 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
    4 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
    8 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
    16: begin
          if not (((PixelFormat.RBitMask=$7C00) and (PixelFormat.GBitMask=$03E0) and (PixelFormat.BBitMask=$001F)) or
            ((PixelFormat.RBitMask=$F800) and (PixelFormat.GBitMask=$07E0) and (PixelFormat.BBitMask=$001F))) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
        end;
    24: begin
          if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
        end;
    32: begin
          if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
        end;
  else
    raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]);
  end;

  FBitCount := ABitCount;
  FHeight := AHeight;
  FWidth := AWidth;
  FWidthBytes := (((AWidth*ABitCount)+31) shr 5) * 4;
  FNextLine := -FWidthBytes;
  FSize := FWidthBytes*FHeight;
  UsePixelFormat := ABitCount in [16, 32];

  FPixelFormat := PixelFormat;

  FPaletteCount := 0;
  if FBitCount<=8 then
    FPaletteCount := 1 shl FBitCount;

  FBitmapInfoSize := SizeOf(TBitmapInfoHeader);
  if UsePixelFormat then
    Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat));
  Inc(FBitmapInfoSize, SizeOf(TRGBQuad)*FPaletteCount);

  GetMem(FBitmapInfo, FBitmapInfoSize);
  FillChar(FBitmapInfo^, FBitmapInfoSize, 0);

  {  BitmapInfo setting.  }
  with FBitmapInfo^.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := FWidth;
    biHeight := FHeight;
    biPlanes := 1;
    biBitCount := FBitCount;
    if UsePixelFormat then
      biCompression := BI_BITFIELDS
    else
    begin
      if (FBitCount=4) and (Compressed) then
        biCompression := BI_RLE4
      else if (FBitCount=8) and (Compressed) then
        biCompression := BI_RLE8
      else
        biCompression := BI_RGB;
    end;
    biSizeImage := FSize;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  InfoOfs := SizeOf(TBitmapInfoHeader);

  if UsePixelFormat then
  begin
    with PLocalDIBPixelFormat(Integer(FBitmapInfo)+InfoOfs)^ do
    begin
      RBitMask := PixelFormat.RBitMask;
      GBitMask := PixelFormat.GBitMask;
      BBitMask := PixelFormat.BBitMask;
    end;

    Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat));
  end;

  FColorTablePos := InfoOfs;

  FColorTable := ColorTable;
  Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);

  FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
  FMemoryImage := MemoryImage or FCompressed;

  {  DIB making.  }
  if not Compressed then
  begin
    if MemoryImage then
    begin
      FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
      if FPBits=nil then
        OutOfMemoryError;
    end else
    begin
      FDC := CreateCompatibleDC(0);

      FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
      if FHandle=0 then
        raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);

      FOldHandle := SelectObject(FDC, FHandle);
    end;
  end;

  FTopPBits := Pointer(Integer(FPBits)+(FHeight-1)*FWidthBytes);
end;

procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
  if Source.FSize=0 then
  begin
    Create;
    FMemoryImage := MemoryImage;
  end else
  begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
    if FCompressed then
    begin
      FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
      GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
      Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
    end else
    begin
      Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
    end;
  end;
end;

procedure TDIBSharedImage.Compress(Source: TDIBSharedImage);

  procedure EncodeRLE4;
  var
    Size: Integer;

    function AllocByte: PByte;
    begin
      if Size mod 4096=0 then
        ReAllocMem(FPBits, Size+4095);
      Result := Pointer(Integer(FPBits)+Size);
      Inc(Size);
    end;

  var
    B1, B2, C: Byte;
    PB1, PB2: Integer;
    Src: PByte;
    X, Y: Integer;

    function GetPixel(x: Integer): Integer;
    begin
      if X and 1=0 then
        Result := PArrayByte(Src)[X shr 1] shr 4
      else
        Result := PArrayByte(Src)[X shr 1] and $0F;
    end;

  begin
    Size := 0;

    for y:=0 to Source.FHeight-1 do
    begin
      x := 0;
      Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
      while x<Source.FWidth do
      begin
        if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) then
        begin
          {  Encoding mode  }
          B1 := 2;
          B2 := (GetPixel(x) shl 4) or GetPixel(x+1);

          Inc(x, 2);

          C := B2;

          while (x<Source.FWidth) and (C and $F=GetPixel(x)) and (B1<255) do
          begin
            Inc(B1);
            Inc(x);
            C := (C shr 4) or (C shl 4);
          end;

          AllocByte^ := B1;
          AllocByte^ := B2;
        end else
        if (Source.FWidth-x>5) and ((GetPixel(x)<>GetPixel(x+2)) or (GetPixel(x+1)<>GetPixel(x+3))) and
          ((GetPixel(x+2)=GetPixel(x+4)) and (GetPixel(x+3)=GetPixel(x+5))) then
        begin
          {  Encoding mode }
          AllocByte^ := 2;
          AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
          Inc(x, 2);
        end else
        begin
          if (Source.FWidth-x<4) then
          begin
            {  Encoding mode }
            while Source.FWidth-x>=2 do
            begin
              AllocByte^ := 2;
              AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
              Inc(x, 2);
            end;

            if Source.FWidth-x=1 then
            begin
              AllocByte^ := 1;
              AllocByte^ := GetPixel(x) shl 4;
              Inc(x);
            end;
          end else
          begin
            {  Absolute mode  }
            PB1 := Size; AllocByte;
            PB2 := Size; AllocByte;

            B1 := 0;
            B2 := 4;

            AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
            AllocByte^ := (GetPixel(x+2) shl 4) or GetPixel(x+3);

            Inc(x, 4);

            while (x+1<Source.FWidth) and (B2<254) do
            begin
              if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) and (GetPixel(x+1)=GetPixel(x+3)) then
                Break;

              AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
              Inc(B2, 2);
              Inc(x, 2);
            end;

            PByte(Integer(FPBits)+PB1)^ := B1;
            PByte(Integer(FPBits)+PB2)^ := B2;
          end;
        end;

        if Size and 1=1 then AllocByte;
      end;

      {  End of line  }
      AllocByte^ := 0;
      AllocByte^ := 0;
    end;

    {  End of bitmap  }
    AllocByte^ := 0;
    AllocByte^ := 1;

    FBitmapInfo.bmiHeader.biSizeImage := Size;
    FSize := Size;
  end;

  procedure EncodeRLE8;
  var
    Size: Integer;

    function AllocByte: PByte;
    begin
      if Size mod 4096=0 then
        ReAllocMem(FPBits, Size+4095);
      Result := Pointer(Integer(FPBits)+Size);
      Inc(Size);
    end;

  var
    B1, B2: Byte;
    PB1, PB2: Integer;
    Src: PByte;
    X, Y: Integer;
  begin
    Size := 0;

    for y:=0 to Source.FHeight-1 do
    begin
      x := 0;
      Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
      while x<Source.FWidth do
      begin
        if (Source.FWidth-x>2) and (Src^=PByte(Integer(Src)+1)^) then
        begin
          {  Encoding mode  }
          B1 := 2;
          B2 := Src^;

          Inc(x, 2);
          Inc(Src, 2);

          while (x<Source.FWidth) and (Src^=B2) and (B1<255) do
          begin
            Inc(B1);
            Inc(x);
            Inc(Src);
          end;

          AllocByte^ := B1;
          AllocByte^ := B2;
        end else
        if (Source.FWidth-x>2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then
        begin
          {  Encoding mode }
          AllocByte^ := 1;
          AllocByte^ := Src^; Inc(Src);
          Inc(x);
        end else
        begin
          if (Source.FWidth-x<4) then
          begin
            {  Encoding mode }
            if Source.FWidth-x=2 then
            begin
              AllocByte^ := 1;
              AllocByte^ := Src^; Inc(Src);

              AllocByte^ := 1;
              AllocByte^ := Src^; Inc(Src);
              Inc(x, 2);
            end else
            begin
              AllocByte^ := 1;
              AllocByte^ := Src^; Inc(Src);
              Inc(x);
            end;
          end else
          begin
            {  Absolute mode  }
            PB1 := Size; AllocByte;
            PB2 := Size; AllocByte;

            B1 := 0;
            B2 := 3;

            Inc(x, 3);

            AllocByte^ := Src^; Inc(Src);
            AllocByte^ := Src^; Inc(Src);
            AllocByte^ := Src^; Inc(Src);

            while (x<Source.FWidth) and (B2<255) do
            begin
              if (Source.FWidth-x>3) and (Src^=PByte(Integer(Src)+1)^) and (Src^=PByte(Integer(Src)+2)^) and (Src^=PByte(Integer(Src)+3)^) then
                Break;

              AllocByte^ := Src^; Inc(Src);
              Inc(B2);
              Inc(x);
            end;

            PByte(Integer(FPBits)+PB1)^ := B1;
            PByte(Integer(FPBits)+PB2)^ := B2;
          end;
        end;

        if Size and 1=1 then AllocByte;
      end;

      {  End of line  }
      AllocByte^ := 0;
      AllocByte^ := 0;
    end;

    {  End of bitmap  }
    AllocByte^ := 0;
    AllocByte^ := 1;

    FBitmapInfo.bmiHeader.biSizeImage := Size;
    FSize := Size;
  end;

begin
  if Source.FCompressed then
    Duplicate(Source, Source.FMemoryImage)
  else begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, True, True);