dxdraws.pas

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

procedure TDirectDrawClipper.SetClipRects(const Rects: array of TRect);
type
  PArrayRect = ^TArrayRect;
  TArrayRect = array[0..0] of TRect;
var
  RgnData: PRgnData;
  i: Integer;
  BoundsRect: TRect;
begin
  BoundsRect := Rect(MaxInt, MaxInt, -MaxInt, -MaxInt);
  for i:=Low(Rects) to High(Rects) do
  begin
    with BoundsRect do
    begin
      Left := Min(Rects[i].Left, Left);
      Right := Max(Rects[i].Right, Right);
      Top := Min(Rects[i].Top, Top);
      Bottom := Max(Rects[i].Bottom, Bottom);
    end;                           
  end;

  GetMem(RgnData, SizeOf(TRgnDataHeader)+SizeOf(TRect)*(High(Rects)-Low(Rects)+1));
  try
    with RgnData^.rdh do
    begin
      dwSize := SizeOf(TRgnDataHeader);
      iType := RDH_RECTANGLES;
      nCount := High(Rects)-Low(Rects)+1;
      nRgnSize := nCount*SizeOf(TRect);
      rcBound := BoundsRect;
    end;
    for i:=Low(Rects) to High(Rects) do
      PArrayRect(@RgnData^.Buffer)^[i-Low(Rects)] := Rects[i];
    DXResult := IClipper.SetClipList(RgnData, 0);
  finally
    FreeMem(RgnData);
  end;
end;

procedure TDirectDrawClipper.SetHandle(Value: THandle);
begin
  DXResult := IClipper.SetHWnd(0, Value);
end;

procedure TDirectDrawClipper.SetIDDClipper(Value: IDirectDrawClipper);
begin
  FIDDClipper := Value;
end;
{  TDirectDrawSurfaceCanvas  }

constructor TDirectDrawSurfaceCanvas.Create(ASurface: TDirectDrawSurface);
begin
  inherited Create;
  FSurface := ASurface;
end;

destructor TDirectDrawSurfaceCanvas.Destroy;
begin
  Release;
  FSurface.FCanvas := nil;
  inherited Destroy;
end;

procedure TDirectDrawSurfaceCanvas.CreateHandle;
begin
  FSurface.DXResult := FSurface.ISurface.GetDC(FDC);
  if FSurface.DXResult=DD_OK then
    Handle := FDC;
end;

procedure TDirectDrawSurfaceCanvas.Release;
begin
  if (FSurface.IDDSurface<>nil) and (FDC<>0) then
  begin
    Handle := 0;
    FSurface.IDDSurface.ReleaseDC(FDC);
    FDC := 0;
  end;
end;

{  TDirectDrawSurface  }

constructor TDirectDrawSurface.Create(ADirectDraw: TDirectDraw);
begin
  inherited Create;
  FDDraw := ADirectDraw;
  FDDraw.FSurfaces.Add(Self);
end;

destructor TDirectDrawSurface.Destroy;
begin
  FCanvas.Free;
  IDDSurface := nil;
  FDDraw.FSurfaces.Remove(Self);
  inherited Destroy;
end;

function TDirectDrawSurface.GetIDDSurface: IDirectDrawSurface;
begin
  if Self<>nil then
    Result := FIDDSurface
  else
    Result := nil;
end;

function TDirectDrawSurface.GetIDDSurface4: IDirectDrawSurface4;
begin
  if Self<>nil then
    Result := FIDDSurface4
  else
    Result := nil;
end;

function TDirectDrawSurface.GetISurface: IDirectDrawSurface;
begin                                  
  Result := IDDSurface;
  if Result=nil then
    raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface']);
end;

function TDirectDrawSurface.GetISurface4: IDirectDrawSurface4;
begin
  Result := IDDSurface4;
  if Result=nil then
    raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface4']);
end;

procedure TDirectDrawSurface.SetIDDSurface(Value: IDirectDrawSurface);
begin
  if Value=nil then
    SetIDDSurface4(nil)
  else
    SetIDDSurface4(Value as IDirectDrawSurface4);
end;

procedure TDirectDrawSurface.SetIDDSurface4(Value: IDirectDrawSurface4);
var
  Clipper: IDirectDrawClipper;
begin
  FIDDSurface4 := Value;
  FIDDSurface := Value as IDirectDrawSurface;
  FStretchDrawClipper := nil;
  FGammaControl := nil;
  FHasClipper := False;
  FillChar(FSurfaceDesc, SizeOf(FSurfaceDesc), 0);

  if FIDDSurface<>nil then
  begin                                
    FHasClipper := (FIDDSurface.GetClipper(Clipper)=DD_OK) and (Clipper<>nil);

    FSurfaceDesc.dwSize := SizeOf(FSurfaceDesc);
    FIDDSurface.GetSurfaceDesc(FSurfaceDesc);

    if FDDraw.DriverCaps.dwCaps2 and DDCAPS2_PRIMARYGAMMA<>0 then
      FIDDSurface.QueryInterface(IID_IDirectDrawGammaControl, FGammaControl);
  end;
end;

procedure TDirectDrawSurface.Assign(Source: TPersistent);
var
  TempSurface: IDirectDrawSurface;
begin
  if Source=nil then
    IDDSurface := nil
  else if Source is TGraphic then
    LoadFromGraphic(TGraphic(Source))
  else if Source is TPicture then
    LoadFromGraphic(TPicture(Source).Graphic)
  else if Source is TDirectDrawSurface then
  begin
    if TDirectDrawSurface(Source).IDDSurface=nil then
      IDDSurface := nil
    else begin
      FDDraw.DXResult := FDDraw.IDraw.DuplicateSurface(TDirectDrawSurface(Source).IDDSurface,
        TempSurface);
      if FDDraw.DXResult=0 then
      begin
        IDDSurface := TempSurface;
      end;
    end;
  end else
    inherited Assign(Source);
end;

procedure TDirectDrawSurface.AssignTo(Dest: TPersistent);
begin
  if Dest is TDIB then
  begin
    TDIB(Dest).SetSize(Width, Height, 24);
    TDIB(Dest).Canvas.CopyRect(Rect(0, 0, TDIB(Dest).Width, TDIB(Dest).Height), Canvas, ClientRect);
    Canvas.Release;
  end else
    inherited AssignTo(Dest);
end;

function TDirectDrawSurface.Blt(const DestRect, SrcRect: TRect; Flags: Integer;
  const DF: DDBLTFX; Source: TDirectDrawSurface): Boolean;
begin
  if IDDSurface<>nil then
  begin
    DXResult := ISurface.Blt(DestRect, Source.IDDSurface, SrcRect, DWORD(Flags), DF);
    Result := DXResult=DD_OK;
  end else
    Result := False;
end;

function TDirectDrawSurface.BltFast(X, Y: Integer; const SrcRect: TRect;
  Flags: Integer; Source: TDirectDrawSurface): Boolean;
begin
  if IDDSurface<>nil then
  begin
    DXResult := ISurface.BltFast(X, Y, Source.IDDSurface, SrcRect, DWORD(Flags));
    Result := DXResult=DD_OK;
  end else
    Result := False;
end;

function TDirectDrawSurface.ColorMatch(Col: TColor): Integer;
var
  DIB: TDIB;
  i, oldc: Integer;
begin
  if IDDSurface<>nil then
  begin
    oldc := Pixels[0, 0];

    DIB := TDIB.Create;
    try
      i := ColorToRGB(Col);
      DIB.SetSize(1, 1, 8);
      DIB.ColorTable[0] := RGBQuad(GetRValue(i), GetGValue(i), GetBValue(i));
      DIB.UpdatePalette;
      DIB.Pixels[0, 0] := 0;

      with Canvas do
      begin
        Draw(0, 0, DIB);
        Release;
      end;
    finally
      DIB.Free;
    end;
    Result := Pixels[0, 0];
    Pixels[0, 0] := oldc;
  end else
    Result := 0;
end;

function TDirectDrawSurface.CreateSurface(const SurfaceDesc: TDDSurfaceDesc): Boolean;
var
  TempSurface: IDirectDrawSurface;
begin
  IDDSurface := nil;

  FDDraw.DXResult := FDDraw.IDraw.CreateSurface(SurfaceDesc, TempSurface, nil);
  FDXResult := FDDraw.DXResult;
  Result := FDDraw.DXResult=DD_OK;
  if Result then
  begin
    IDDSurface := TempSurface;
    TransparentColor := 0;
  end;
end;

{$IFDEF DelphiX_Delphi4}
function TDirectDrawSurface.CreateSurface(const SurfaceDesc: TDDSurfaceDesc2): Boolean;
var
  TempSurface: IDirectDrawSurface4;
begin
  IDDSurface := nil;

  FDDraw.DXResult := FDDraw.IDraw4.CreateSurface(SurfaceDesc, TempSurface, nil);
  FDXResult := FDDraw.DXResult;
  Result := FDDraw.DXResult=DD_OK;
  if Result then
  begin
    IDDSurface4 := TempSurface;
    TransparentColor := 0;
  end;
end;
{$ENDIF}

procedure TDirectDrawSurface.Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
  Transparent: Boolean);
const
  BltFastFlags: array[Boolean] of Integer =
    (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
  BltFlags: array[Boolean] of Integer =
    (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
var
  DestRect: TRect;
  DF: DDBLTFX;
  Clipper: IDirectDrawClipper;
  i: Integer;
begin
  if Source<>nil then
  begin
    if (X>Width) or (Y>Height) then Exit;

    if (SrcRect.Left>SrcRect.Right) or (SrcRect.Top>SrcRect.Bottom) then
    begin
      {  Mirror  }
      if ((X+Abs(SrcRect.Left-SrcRect.Right))<=0) or
        ((Y+Abs(SrcRect.Top-SrcRect.Bottom))<=0) then Exit;

      DF.dwsize := SizeOf(DF);
      DF.dwDDFX := 0;

      if SrcRect.Left>SrcRect.Right then
      begin
        i := SrcRect.Left; SrcRect.Left := SrcRect.Right; SrcRect.Right := i;
        DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORLEFTRIGHT;
      end;
                         
      if SrcRect.Top>SrcRect.Bottom then
      begin
        i := SrcRect.Top; SrcRect.Top := SrcRect.Bottom; SrcRect.Bottom := i;
        DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORUPDOWN;
      end;

      with SrcRect do                                     
        DestRect := Bounds(X, Y, Right-Left, Bottom-Top);

      if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
      begin
        if DF.dwDDFX and DDBLTFX_MIRRORLEFTRIGHT<>0 then
        begin
          i := SrcRect.Left;
          SrcRect.Left := Source.Width-SrcRect.Right;
          SrcRect.Right := Source.Width-i;
        end;

        if DF.dwDDFX and DDBLTFX_MIRRORUPDOWN<>0 then
        begin
          i := SrcRect.Top;
          SrcRect.Top := Source.Height-SrcRect.Bottom;
          SrcRect.Bottom := Source.Height-i;
        end;
                                                   
        Blt(DestRect, SrcRect, BltFlags[Transparent] or DDBLT_DDFX, df, Source);
      end;
    end else
    begin
      with SrcRect do
        DestRect := Bounds(X, Y, Right-Left, Bottom-Top);

      if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
      begin
        if FHasClipper then
        begin
          DF.dwsize := SizeOf(DF);
          DF.dwDDFX := 0;
          Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
        end else
        begin
          BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
          if DXResult=DDERR_BLTFASTCANTCLIP then
          begin
            ISurface.GetClipper(Clipper);
            if Clipper<>nil then FHasClipper := True;

            DF.dwsize := SizeOf(DF);
            DF.dwDDFX := 0;
            Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
          end;
        end;
      end;
    end;
  end;
end;

{$IFDEF DelphiX_Delphi4}
procedure TDirectDrawSurface.Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean);
const
  BltFastFlags: array[Boolean] of Integer =
    (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
  BltFlags: array[Boolean] of Integer =
    (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
var
  DestRect, SrcRect: TRect;
  DF: DDBLTFX;
  Clipper: IDirectDrawClipper;
begin
  if Source<>nil then
  begin
    SrcRect := Source.ClientRect;
    DestRect := Bounds(X, Y, Source.Width, Source.Height);

    if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
    begin
      if FHasClipper then
      begin
        DF.dwsize := SizeOf(DF);
        DF.dwDDFX := 0;
        Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
      end else
      begin