dxinput.pas

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

  AName := Name;
  Effect := Self;

  p := AnsiPos('.', AName);
  while p<>0 do
  begin
    i := Effect.IndexOf(AName);
    if i<>-1 then
    begin
      Result := Effect[i];
      Exit;
    end else
    begin
      i := Effect.IndexOf(Copy(Name, 1, p-1));
      if i=-1 then
        raise EForceFeedbackEffectError.CreateFmt(SEffectNotFound, [Name]);
      Effect := Effect[i];
      AName := Copy(Name, p+1, MaxInt);
      p := AnsiPos('.', AName);
    end;
  end;

  i := Effect.IndexOf(Name);
  if i=-1 then
    raise EForceFeedbackEffectError.CreateFmt(SEffectNotFound, [Name]);
  Result := Effect[i];
end;

function TForceFeedbackEffect.IndexOf(const Name: string): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i:=0 to Count-1 do
    if Effects[i].Name=Name then
    begin
      Result := i;
      Break;
    end;
end;

function TForceFeedbackEffect.HasInterface: Boolean;
begin
  Result := (FEffectType<>etNone) and ((FObject.FEffect<>nil) or (FObject2.FEffect<>nil));
end;

procedure TForceFeedbackEffect.MakeEff;
var
  Constant2: TPoint;
begin
  FObject.Clear;
  FObject2.Clear;

  with Constant2 do
  begin
    X := -FConstant.X;
    Y := -FConstant.Y;
  end;

  case FEffectType of
    etConstantForce:  { etConstantForce }
        begin
          with FObject do
          begin
            FDirections[0] := Constant2.X;
            FDirections[1] := Constant2.Y;

            FAxesCount := 2;
            FAxes[0] := DIJOFS_X;
            FAxes[1] := DIJOFS_Y;

            with Constant2 do
              FConstantForce.lMagnitude := Trunc(Sqrt(X*X+Y*Y));

            Init(Self);
            with Feff do
            begin
              cbTypeSpecificParams := SizeOf(FConstantForce);
              lpvTypeSpecificParams := @FConstantForce;
            end;
          end;
        end;
    etPeriodic:       { etPeriodic }
        begin
          with FObject do
          begin
            FDirections[0] := Constant2.X;
            FDirections[1] := Constant2.Y;

            FAxesCount := 2;
            FAxes[0] := DIJOFS_X;
            FAxes[1] := DIJOFS_Y;

            with FPeriodic do
            begin
              with Constant2 do
                dwMagnitude := Trunc(Sqrt(X*X+Y*Y));
              lOffset := 0;
              dwPhase := 0;
              dwPeriod := ConvertTime(FPeriod);
            end;

            Init(Self);
            with Feff do
            begin
              cbTypeSpecificParams := SizeOf(FPeriodic);
              lpvTypeSpecificParams := @FPeriodic;
            end;
          end;
        end;
    etCondition:      { etCondition }
        begin
          with FObject do
          begin
            FillChar(FDirections, SizeOf(FDirections), 0);

            FAxesCount := 1;
            FAxes[0] := DIJOFS_X;

            with FCondition do
            begin
              lOffset := -Constant2.X;
              lPositiveCoefficient := Self.FCondition.X;
              lNegativeCoefficient := -Self.FCondition.X;
              dwPositiveSaturation := 0;
              dwNegativeSaturation := 0;
              lDeadBand := 0;
            end;

            Init(Self);
            with Feff do
            begin
              cbTypeSpecificParams := SizeOf(FCondition);
              lpvTypeSpecificParams := @FCondition;
            end;
          end;

          with FObject2 do
          begin
            FillChar(FDirections, SizeOf(FDirections), 0);

            FAxesCount := 1;
            FAxes[0] := DIJOFS_Y;

            with FCondition do
            begin
              lOffset := -Constant2.Y;
              lPositiveCoefficient := Self.FCondition.Y;
              lNegativeCoefficient := -Self.FCondition.Y;
              dwPositiveSaturation := 0;
              dwNegativeSaturation := 0;
              lDeadBand := 0;
            end;

            Init(Self);
            with Feff do
            begin
              cbTypeSpecificParams := SizeOf(FCondition);
              lpvTypeSpecificParams := @FCondition;
            end;
          end;
        end;
  end;
end;

procedure TForceFeedbackEffect.CreateEffect;
                                            
  function FindEffectCallBack(const pdei: TDIEffectInfoA;
    pvRef: Pointer): HRESULT; stdcall;
  begin
    with TForceFeedbackEffect(pvRef) do
    begin
      FFindEffectFlag := True;
      FFindEffectGUID := pdei.guid;
    end;

    Result := DIENUM_STOP;
  end;

  procedure CreateIEffectGuid(const GUID: TGUID;
    EffectObject: TForceFeedbackEffectObject);
  begin
    if EffectObject.Feff.dwSize=0 then Exit;

    if FRoot.FInput.FDevice2<>nil then
      FRoot.FInput.FDevice2.CreateEffect(GUID, EffectObject.Feff, EffectObject.FEffect, nil);
  end;

  procedure CreateIEffect(dwFlags: DWORD;
    EffectObject: TForceFeedbackEffectObject);
  begin
    if EffectObject.Feff.dwSize=0 then Exit;

    if FRoot.FInput.FDevice2<>nil then
    begin
      FFindEffectFlag := False;
      FRoot.FInput.FDevice2.EnumEffects(@FindEffectCallBack,
        Self, dwFlags);
      if FFindEffectFlag then
        CreateIEffectGuid(FFindEffectGUID, EffectObject);
    end;
  end;

begin
  FObject.Release;
  FObject2.Release;

  if (FRoot.FInput=nil) or (FRoot.FInput.FDevice2=nil) or
    (not FRoot.FInput.FForceFeedbackDevice) or
    (not FRoot.FInput.FForceFeedback) then Exit;

  if FEffectType=etNone then Exit;

  MakeEff;
  case FEffectType of
    etConstantForce:
        begin
          CreateIEffectGUID(GUID_ConstantForce, FObject);
        end;
    etPeriodic:
        begin
          CreateIEffect(DIEFT_PERIODIC, FObject);
        end;
    etCondition:
        begin
          CreateIEffect(DIEFT_CONDITION, FObject);
          CreateIEffect(DIEFT_CONDITION, FObject2);
        end;
  end;

  if Playing and (Time=-1) then
    Start;
end;

procedure TForceFeedbackEffect.ChangeEffect;
var
  dwFlags: DWORD;
begin
  if HasInterface then
  begin
    MakeEff;

    dwFlags := DIEP_DIRECTION or DIEP_DURATION or DIEP_ENVELOPE or
      DIEP_GAIN or DIEP_SAMPLEPERIOD or DIEP_TRIGGERBUTTON or
      DIEP_TRIGGERREPEATINTERVAL or DIEP_TYPESPECIFICPARAMS;

    if Playing then
      dwFlags := dwFlags or DIEP_START;

    if FObject.FEffect<>nil then FObject.FEffect.SetParameters(FObject.Feff, dwFlags);
    if FObject2.FEffect<>nil then FObject2.FEffect.SetParameters(FObject2.Feff, dwFlags);
  end;
end;

function TForceFeedbackEffect.GetPlaying: Boolean;
var
  dwFlags: DWORD;
begin
  Result := False;

  if not FPlaying then Exit;

  if FPlaying and (FTime=-1) then
  begin
    Result := True;
    Exit;
  end;

  if FObject.FEffect<>nil then
  begin
    dwFlags := 0;
    FObject.FEffect.GetEffectStatus(dwFlags);
    if dwFlags and DIEGES_PLAYING<>0 then
    begin
      Result := True;
      Exit;
    end;
  end;

  if FObject2.FEffect<>nil then
  begin
    dwFlags := 0;
    FObject2.FEffect.GetEffectStatus(dwFlags);
    if dwFlags and DIEGES_PLAYING<>0 then
    begin
      Result := True;
      Exit;
    end;
  end;

  if not Result then
    FPlaying := False;
end;

function TForceFeedbackEffect.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TForceFeedbackEffect.GetEffect(Index: Integer): TForceFeedbackEffect;
begin
  Result :=FList[Index];
end;

function TForceFeedbackEffect.GetIndex: Integer;
begin
  if FParent<>nil then
    Result := FParent.FList.IndexOf(Self)
  else
    Result := 0;
end;

procedure TForceFeedbackEffect.SetIndex(Value: Integer);
begin
  if FParent<>nil then
  begin
    FParent.FList.Remove(Self);
    FParent.FList.Insert(Value, Self);
  end;
end;

procedure TForceFeedbackEffect.SetParent(Value: TForceFeedbackEffect);
begin
  if Parent<>Value then
  begin
    if (Value=nil) or (FRoot<>Value.FRoot) then
      raise EForceFeedbackEffectError.CreateFmt(SCannotChanged, ['Parent']);

    FParent.FList.Remove(Self);
    FParent := Value;
    FParent.FList.Add(Self);
  end;
end;

procedure TForceFeedbackEffect.SetAttackLevel(Value: Integer);
begin
  if Value<0 then Value := 0;
  if Value>10000 then Value := 10000;

  if FAttackLevel<>Value then
  begin
    FAttackLevel := Value;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetAttackTime(Value: Integer);
begin
  if Value<0 then Value := 0;

  if FAttackTime<>Value then
  begin
    FAttackTime := Value;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetCondition(Value: TPoint);
begin
  with Value do
  begin
    if X<-10000 then X := -10000;
    if X>+10000 then X := +10000;

    if Y<-10000 then Y := -10000;
    if Y>+10000 then Y := +10000;
  end;

  if not CompareMem(@FCondition, @Value, SizeOf(FCondition)) then
  begin
    FCondition := Value;

    if HasInterface then
      ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetConstant(Value: TPoint);
begin
  with Value do
  begin
    if X<-10000 then X := -10000;
    if X>+10000 then X := +10000;

    if Y<-10000 then Y := -10000;
    if Y>+10000 then Y := +10000;
  end;

  if not CompareMem(@FConstant, @Value, SizeOf(FConstant)) then
  begin
    FConstant := Value;

    if HasInterface then
      ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetEffectType(Value: TForceFeedbackEffectType);
begin
  if FEffectType<>Value then
  begin
    FEffectType := Value;
    Stop;
    CreateEffect;
  end;
end;

procedure TForceFeedbackEffect.SetFadeLevel(Value: Integer);
begin
  if Value<0 then Value := 0;
  if Value>10000 then Value := 10000;

  if FFadeLevel<>Value then
  begin
    FFadeLevel := Value;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetFadeTime(Value: Integer);
begin
  if Value<0 then Value := 0;

  if FFadeTime<>Value then
  begin
    FFadeTime := Value;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetPeriod(Value: Integer);
begin
  if Value<0 then Value := 0;

  if FPeriod<>Value then
  begin
    FPeriod := Value;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetPower(Value: Integer);
begin
  if Value<0 then Value := 0;
  if Value>10000 then Value := 10000;

  if FPower<>Value then
  begin
    FPower := Value;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.SetTime(Value: Integer);
begin
  if (Value<>-1) and (Value<0) then Value := 0;

  if FTime<>Value then
  begin
    FTime := Value;
    Stop;
    ChangeEffect;
  end;
end;

procedure TForceFeedbackEffect.Start;

  procedure StartEffect(Effect: IDirectInputEffect);
  var
    hr: HRESULT;
  begin
    if Effect<>nil then
    begin
      hr := Effect.Start(1, 0);
      if (hr=DIERR_INPUTLOST) or (hr=DIERR_NOTACQUIRED) then
      begin
        FRoot.FInput.Acquire;
        Effect.Start(1, 0);
      end;
    end;
  end;

var
  i: Integer;
begin
  for i:=0 to Count-1 do
    Effects[i].Start;

  if not HasInterface then
  begin
    CreateEffect;
    if not HasInterface then Exit;
  end;

  StartEffect(FObject.FEffect);
  StartEffect(FObject2.FEffect);

  FPlaying := True;
end;

procedure TForceFeedbackEffect.Stop;
var
  i: Integer;
begin
  if Playing then
  begin
    FPlaying := False;
    if FObject.FEffect<>nil then FObject.FEffect.Stop;
    if FObject2.FEffect<>nil then FObject2.FEffect.Stop;
  end;

  for i:=0 to Count-1 do
    Effects[i].Stop;
end;

procedure TForceFeedbackEffect.Unload(Recurse: Boolean);
var
  i: Integer;
begin
  if Playing then
  begin
    if FObject.FEffect<>nil then FObject.FEffect.Stop;
    if FObject2.FEffect<>nil then FObject2.FEffect.Stop;
  end;

  if FObject.FEffect<>nil then FObject.FEffect.Unload;
  if FObject2.FEffect<>nil then FObject2.FEffect.Unload;

  if Recurse then
  begin
    for i:=0 to Count-1 do
      Effects[i].Unload(True);
  end;
end;

type
  TForceFeedbackEffectItem = class(TCollectionItem)
  private
    FName: string;
    FEffectType: TForceFeedbackEffectType;
    FAttackLevel: Integer;
    FAttackTime: Integer;
    FConditionX: Integer;
    FConditionY: Integer;
    FConstantX: Integer;
    FConstantY: Integer;
    FFadeLevel: Integer;
    FFadeTime: Integer;
    FPeriod: Integer;
    FPower: Integer;
    FTime: Integer;
    FEffects: TCollection;
    function GetStoredEffects: Boolean;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;
  published
    property Name: string read FName write FName;
    property EffectType: TForceFeedbackEffectType read FEffectType write FEffectType;
    property AttackLevel: Integer read FAttackLevel write FAttackLevel default 0;
    property AttackTime: Integer read FAttackTime write FAttackTime default 0;
    property ConditionX: Integer read FConditionX write FConditionX default 0;
    property ConditionY: Integer read FConditionY write FConditionY default 0;
    property ConstantX: Integer read FConstantX write FConstantX default 0;
    property ConstantY: Integer read FConstantY write FConstantY default 0;
    property FadeLevel: Integer read FFadeLevel write FFadeLevel default 0;
    property FadeTime: Integer read FFadeTime write FFadeTime default 0;
    property Period: Integer read FPeriod write FPeriod;
    property Power: Integer read FPower write FPower;
    property Time: Integer read FTime write FTime;
    property Effects: TCollection read FEffects write FEffects stored GetStoredEffects;