dx9library.pas

3D GameStudio 的Delphi开发包

//////////////////////////////////////////////////////////////////////
//
// Delphi DirectX 9 Library routines for the A6_5x Engine (acknex.dll) and plugin dll's done by
// Michal Messerschmidt aka LazyDog of Lazy Dog Software
// (www.LazyDogSoftware.com)
// (c) Lazy Dog Software / Michael Messerschmidt 2006
//
// SDK Version 6.50.6
//
// tested on Delphi 5,6,7,2005 & 2006
//////////////////////////////////////////////////////////////////////

Interface

Uses Windows, Graphics,  // Graphics must be declared after Windows unit!!!
     {$IFDEF USEDLL} A6DLL {$ELSE} A6Engine {$ENDIF};

function ConvertPixelFormat(var B : TBitmap; P: TPixelFormat) : VAR_; {$IFDEF USEDLL} cdecl; exports ConvertPixelFormat; {$ENDIF}
function TextureToBitmap(BMap : PBMap; var WorkBitMap: TBitmap): VAR_;{$IFDEF USEDLL} cdecl; exports TextureToBitmap; {$ENDIF}
function BitmapToTexture(BMap : PBMap; var WorkBitMap: TBitmap): VAR_;{$IFDEF USEDLL} cdecl; exports BitmapToTexture; {$ENDIF}

function DirectDeviceReset : Boolean;

Implementation
uses Direct3D9, SysUtils;

function ConvertPixelFormat(var B : TBitmap; P: TPixelFormat) : VAR_;

var Work : TBitmap;
begin
  Result := _VAR(2);  // default to not supported format

  if not (P in [pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit]) then Exit;

  Result := _VAR(1);  // default to failed

  Work := TBitmap.Create;
  try
    try
      Work.PixelFormat := P;
      Work.Width := B.Width;
      Work.Height := B.Height;
      BitBlt(Work.Canvas.Handle,0,0,B.Width,B.Height,B.Canvas.Handle,0,0,SRCCOPY);
      B.Assign(Work);
      Result := 0;  // successful
    except
    end;
  finally
    Work.Free;
  end;
end;


function TextureToBitmap(BMap : PBMap; var WorkBitMap: TBitmap): VAR_;

// this function was improved and updated to DirectX9 by me but it was
// originally from janFX Library  http://www.jansfreeware.com/

type TRGBQuadArray = ARRAY[WORD] OF INTEGER;
     pRGBQuadArray = ^TRGBQuadArray;
     PWORD = ^WORD;

var dx9tex : IDIRECT3DTEXTURE9;
    ddsd   : TD3DSURFACE_DESC;
    d3dlr  : TD3DLOCKED_RECT;
    Pixels : PByte;
    Row    : pRGBQuadArray;
    Row16  : pWordArray;
    x,y    : LongWord;
    Target : PLongWord;
begin
  Result := _VAR(1);  // default to failed

  // we can not be sure that the entity texture exists - it could be purged
  if (BMap.d3dtex <> Nil) then
  begin
    dx9tex := IDIRECT3DTEXTURE9(BMap.d3dtex);

    if dx9tex <> Nil then
    begin
      // check the texture format
      if not FAILED(dx9tex.GetLevelDesc(0,ddsd)) then
      begin
        if not (ddsd.Format in [D3DFMT_A8R8G8B8,D3DFMT_A4R4G4B4,D3DFMT_A1R5G5B5,D3DFMT_R5G6B5]) then
        begin
          Result := _VAR(2);  // format not supported
          Exit;
        end;

        WorkBitMap.Width := ddsd.Width;
        WorkBitMap.Height := ddsd.Height;

        // lock the texture and retrieve a pointer to the surface
        if not FAILED(dx9tex.LockRect(0,d3dlr,nil,D3DLOCK_READONLY)) then
        try
          try
	    pixels := PByte(d3dlr.pBits);

            // do we have a 16 bit or 32 bit format? All 4 formats are possible:
  	    if ddsd.Format = D3DFMT_A8R8G8B8 then
            begin
              WorkBitMap.PixelFormat := pf32Bit;
              y := 0;

              while y < ddsd.Height do
              begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row := WorkBitMap.ScanLine[y];
                x := 0;

                while x < ddsd.Width do
                begin
                  Row[x] := Target^;
                  Target := pointer(LongWord(Target) + 4);
                  Inc(x);
                end;

                Inc(y);
              end;
            end
            else
            if ddsd.Format = D3DFMT_A4R4G4B4 then
            begin
              WorkBitMap.PixelFormat := pf16Bit;
              y := 0;

              while (y < ddsd.Height) do
	      begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row16  := WorkBitMap.ScanLine[y];
                x := 0;

                while x < ddsd.Width do
                begin
                  Row16[x] := PWord(Target)^;
                  Target   := pointer(LongWord(Target) + 2);
                  Inc(x);
                end;

                Inc(y);
              end
            end
            else
            if ddsd.Format = D3DFMT_A1R5G5B5 then
            begin
              WorkBitMap.PixelFormat := pf16Bit;
              y := 0;

              while y < ddsd.Height do
              begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row16  := WorkBitMap.ScanLine[y];
                x := 0;

                while x < ddsd.Width do
                begin
                  Row16[x] := PWord(Target)^;
                  Target   := pointer(LongWord(Target) + 2);
                  Inc(x);
                end;

                Inc(y);
              end;
            end
            else
            if ddsd.Format = D3DFMT_R5G6B5 then
            begin
              WorkBitMap.PixelFormat := pf16Bit;
              y := 0;

              while y < ddsd.Height do
              begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row16  := WorkBitMap.ScanLine[y];
                x := 0;

                while x < ddsd.Width do
                begin
                  Row16[x] := PWord(Target)^;
                  Target := pointer(LongWord(Target) + 2);
                  Inc(x);
                end;

                Inc(y);
              end;
            end;

            Result := 0;  // successful

          except
          end;
        finally
          // Unlock the surface again
          dx9tex.UnlockRect(0);
        end;
      end;
    end;
  end;
end;

function BitmapToTexture(BMap : PBMap; var WorkBitMap: TBitmap): VAR_;

// this function was improved and updated to DirectX9 by me but it was
// originally from janFX Library  http://www.jansfreeware.com/

type TRGBQuadArray = ARRAY[WORD] OF INTEGER;
     pRGBQuadArray = ^TRGBQuadArray;
     PWORD = ^WORD;

var dx9tex : IDIRECT3DTEXTURE9;
    ddsd   : TD3DSURFACE_DESC;
    d3dlr  : TD3DLOCKED_RECT;
    Pixels : PByte;
    Row    : pRGBQuadArray;
    Row16  : pWordArray;
    x,y    : LongWord;
    Target : PLongWord;
begin
  Result := _VAR(1);  // default to failed

  // we can not be sure that the entity texture exists - it could be purged
  if BMap.d3dtex <> Nil then
  begin
    dx9tex := IDIRECT3DTEXTURE9(BMap.d3dtex);

    if dx9tex <> Nil then
    begin
      // check the texture format
      if not FAILED(dx9tex.GetLevelDesc(0,ddsd)) then
      begin
        if not (ddsd.Format in [D3DFMT_A8R8G8B8,D3DFMT_A4R4G4B4,D3DFMT_A1R5G5B5,D3DFMT_R5G6B5]) then
        begin
          Result := _VAR(2);  // format not supported
          Exit;
        end;

        // if the bitmaps are different sizes, error
        if (LongWord(WorkBitMap.Width) <> ddsd.Width) or (LongWord(WorkBitMap.Height) <> ddsd.Height) then
        begin
          Result := _VAR(3);  // failed, different sizes
          Exit;
        end;

        // lock the texture and retrieve a pointer to the surface
        if not FAILED(dx9tex.LockRect(0,d3dlr,nil,0)) then
        try
          try
	    Pixels := PByte(d3dlr.pBits);

            // do we have a 16 bit or 32 bit format? All 4 formats are possible:
	    if ddsd.Format = D3DFMT_A8R8G8B8 then
            begin
              WorkBitMap.PixelFormat := pf32Bit;
              y := 0;

              while y < ddsd.Height do
              begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row    := WorkBitMap.ScanLine[y];
                x      := 0;

                while x < ddsd.Width do
                begin
                  Target^ := Row[x];
                  Target  := pointer(LongWord(Target) + 4);
                  Inc(x);
                end;

                Inc(y);
              end;
            end
            else
            if ddsd.Format = D3DFMT_A4R4G4B4 then
            begin
              WorkBitMap.PixelFormat := pf16Bit;
              y := 0;

              while y < ddsd.Height do
	      begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row16  := WorkBitMap.ScanLine[y];
                x      := 0;

                while (x < ddsd.Width) do
                begin
                  PWord(Target)^ := Row16[x];
                  Target := pointer(LongWord(Target) + 2);
                  Inc(x);
                end;

                Inc(y);
              end
            end
            else
            if ddsd.Format = D3DFMT_A1R5G5B5 then
            begin
              WorkBitMap.PixelFormat := pf16Bit;
              y := 0;

              while y < ddsd.Height do
              begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row16  := WorkBitMap.ScanLine[y];
                x := 0;

                while (x < ddsd.Width) do
                begin
                  PWord(Target)^ := Row16[x];
                  Target := pointer(LongWord(Target) + 2);
                  Inc(x);
                end;

                Inc(y);
              end;
            end
            else
            if ddsd.Format = D3DFMT_R5G6B5 then
            begin
              WorkBitMap.PixelFormat := pf16Bit;
              y := 0;

              while y < ddsd.Height do
              begin
                Target := pointer(LongWord(Pixels) + (y * LongWord(d3dlr.Pitch)));
                Row16  := WorkBitMap.ScanLine[y];
                x := 0;

                while x < ddsd.Width do
                begin
                  PWord(Target)^ := Row16[x];
                  Target := pointer(LongWord(Target) + 2);
                  Inc(x);
                end;

                Inc(y);
              end;
            end;

            Result := 0;

          except
          end;
        finally
          // Unlock the surface again
          dx9tex.UnlockRect(0);
        end;
      end;
    end;
  end;
end;

// this routine allows windows to be opened when the game engine
// is in full screen mode.  It does nothing if not in full screen mode.
function DirectDeviceReset : Boolean;

var pddev : IDirect3DDevice9;
begin
  Result := False;

  if _INT(ev.video_screen^) = 1 then // full screen
  begin
    pddev := IDirect3DDevice9(ev.pd3ddev);

    if pddev = Nil then Exit;

    pddev.endscene;
    pddev.SetDialogBoxMode(True);
  end;

  Result := True;
end;