[xkor]

Прошу:

unit DDS_DXT1;

interface

uses Graphics;

type
  Color8888 = record
    r: byte;
    g: byte;
    b: byte;
    a: byte;
  end;

function DDS_DXT1_To_Bitmap(var dat): TBitmap;

implementation

procedure ReadColor(Data: Word; var OutD: Color8888);
var
  r, g, b: Byte;
begin
  b := Data and $1f;
  g := (Data and $7E0) shr 5;
  r := (Data and $F800) shr 11;

  OutD.r := r shl 3;
  OutD.g := g shl 2;
  OutD.b := b shl 3;
end;

function DDS_DXT1_To_Bitmap(var dat): TBitmap;
var
  x, y, i, j, k, Select: Integer;
  Temp: PByte;
  dw: packed record
    data1: array[0..11] of Byte;
    Height: Integer;
    Width: Integer;
  end absolute dat;
  colours: array[0..3] of Color8888;
  color_0, color_1: Word;
  bitmask, Offset: Cardinal;
  Data: array of Byte;
begin
 try
  SetLength(Data,dw.Width*dw.Height*4);
  Temp := PByte(Cardinal(@dat)+128);
  colours[0].a := $FF;
  colours[1].a := $FF;
  colours[2].a := $FF;
  for y := 0 to (dw.Height div 4)-1 do begin
    for x := 0 to (dw.Width div 4)-1 do begin
      color_0 := PWord(Temp)^;
      Inc(Temp,2);
      color_1 := PWord(Temp)^;
      ReadColor(color_0, colours[0]);
      ReadColor(color_1, colours[1]);
      Inc(Temp,2);
      bitmask := PCardinal(Temp)^;
      Inc(Temp,4);

      if (color_0 > color_1) then begin
        colours[2].b := (2 * colours[0].b + colours[1].b + 1) div 3;
        colours[2].g := (2 * colours[0].g + colours[1].g + 1) div 3;
        colours[2].r := (2 * colours[0].r + colours[1].r + 1) div 3;

        colours[3].b := (colours[0].b + 2 * colours[1].b + 1) div 3;
        colours[3].g := (colours[0].g + 2 * colours[1].g + 1) div 3;
        colours[3].r := (colours[0].r + 2 * colours[1].r + 1) div 3;
        colours[3].a := $FF;
      end else begin
        colours[2].b := (colours[0].b + colours[1].b) div 2;
        colours[2].g := (colours[0].g + colours[1].g) div 2;
        colours[2].r := (colours[0].r + colours[1].r) div 2;

        colours[3].b := (colours[0].b + 2 * colours[1].b + 1) div 3;
        colours[3].g := (colours[0].g + 2 * colours[1].g + 1) div 3;
        colours[3].r := (colours[0].r + 2 * colours[1].r + 1) div 3;
        colours[3].a := $00;
      end;

      k:=0;
      for j := 0 to 3 do begin
        for i := 0 to 3 do begin

          Select := (bitmask and ($03 shl (k*2))) shr (k*2);

          if (((x*4 + i) < dw.Width) and ((y*4 + j) < dw.Height)) then begin
            Offset := (y*4 + j) * dw.Width*4 + (x*4 + i) * 4;
            Data[Offset + 0] := colours[Select].r;
            Data[Offset + 1] := colours[Select].g;
            Data[Offset + 2] := colours[Select].b;
            Data[Offset + 3] := 0;//colours[Select].a;
          end;
          Inc(k);
        end;
      end;
    end;
  end;
  Result:=TBitmap.Create;
  Result.SetSize(dw.Width,dw.Height-4);
  for y := 4 to dw.Height-1 do
    for x := 0 to dw.Width-1 do
      Result.Canvas.Pixels[x,y-4]:=PColor(@Data[(y*16+x)*4])^;
 except
  Result:=nil;
 end;
end;

end.

писал это ещё под С4 но вроде с тех пор в этом ничего не менялось, тут правда тока для PledgeCrest, но для AllyCrest просто размерчики подогнать или сделать выбор для них чтоб универсально было
юзать например так (вырезка из моего бота):

TFixPck = packed record case Integer of
    0:(ch:    array[Word] of Char);
    1:(bt:    array[Word] of Byte);
    2:(size:  Word;
       id:    Byte;
       dbt:   array[0..65532] of Byte);
  end;

var pck: TFixPck;

procedure TBotMain.RecvPledgeCrest;
var
  _clan: TClan;
begin
  _clan:=wo.GetClanByClanCrestId(rwpck.ReadD);
  if _clan<>nil then _clan.bmpIcon:=DDS_DXT1_To_Bitmap(pck.dbt[8]);
end;