mmdevice.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]              =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 05.09.98 - 22:49:29 $                                        =}
{========================================================================}
unit MMDevice;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Classes,
    SysUtils,
    MMSystem,
    MMObj,
    MMObsrv,
    MMUtils;

type
    { D3: This lines rely on current Win32 API}
    TMMAudioDeviceType = (dtMidiIn,dtMidiOut,dtWaveIn,dtWaveOut,dtAux,dtMixer);

{$IFDEF WIN32}
    TMMManufacturerId  = WORD;
    TMMProductId       = WORD;
    TMMVersion         = Byte;
{$ENDIF}

const
    defAudioDeviceType  = dtWaveOut;
    defDeviceId         = 0;

    { D3: This lines rely on current Win32 API}
type
    {-- TMMDeviceCaps ---------------------------------------------------}
    TMMDeviceCaps       = class(TPersistent)
    private
      FManufacturerId: TMMManufacturerId;
      FProductId     : TMMProductId;
      FVerMajor      : TMMVersion;
      FVerMinor      : TMMVersion;
      FProductName   : string;

      FWDummy        : Word;
      FVDummy        : TMMVersion;

      procedure SetDummyStr(const Value: string);
    public
      procedure Clear;
    published
      property ManufacturerId: TMMManufacturerId read FManufacturerId write FWDummy stored False;
      property ProductId     : TMMProductId read FProductId write FWDummy stored False;
      property VerMajor      : TMMVersion read FVerMajor write FVDummy stored False;
      property VerMinor      : TMMVersion read FVerMinor write FVDummy stored False;
      property ProductName   : string read FProductName write SetDummyStr stored False;
    end;

    {-- TMMCustomAudioDevice ------------------------------------------------}
    TMMCustomAudioDevice = class(TMMNonVisualComponent)
    private
      FActive    : Boolean;
      FDeviceType: TMMAudioDeviceType;
      FDeviceId  : TMMDeviceId;
      FDeviceCaps: TMMDeviceCaps;
      FObservable: TMMObservable;

      FTempActive: Boolean;
      FDummyInt  : Integer;
      FDummyBool : Boolean;

      FOnChange  : TNotifyEvent;

      procedure SetDeviceType(Value: TMMAudioDeviceType);
      procedure SetDeviceId(Value: TMMDeviceId);
      function  GetDeviceCount: Integer;
      function  GetDevices(index: integer): string;
      procedure SetDeviceCaps(const Value: TMMDeviceCaps);
      function  GetMixerId: TMMDeviceId;
      function  GetDeviceCapsByID(AnID: TMMDeviceId): TMMDeviceCaps;

    protected
      procedure Open; virtual;
      procedure Close; virtual;
      procedure UpdateDevice; virtual;
      procedure RetrieveDeviceCaps;
      procedure SetActive(Value: Boolean);
      function  GetActive: Boolean;
      procedure Changed; virtual;
      procedure DoChange; dynamic;
      procedure Loaded; override;
      { If descendant needs to immediately update device id w/o reopening }
      procedure SetDeviceIdDirect(Value: TMMDeviceId);
      function  GetMapper: Boolean;

    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;

      procedure AddObserver(O: TMMObserver);
      procedure RemoveObserver(O: TMMObserver);

      function  ValidDevice: Boolean;

      procedure GetDeviceList(List: TStrings; IncludeMapper: Boolean);
      function  GetDeviceType: TMMAudioDeviceType;

      { badDeviceId if no mixer for device }
      property  MixerId: TMMDeviceId read GetMixerId;

      property  Devices[index: integer]: string read GetDevices;

    protected
      property  DeviceType: TMMAudioDeviceType read FDeviceType write SetDeviceType default defAudioDeviceType;

      {$IFDEF BUILD_ACTIVEX} public {$ELSE} protected {$ENDIF}
      property  DeviceCapsByID[AnID: TMMDeviceId]: TMMDeviceCaps read GetDeviceCapsById;

    published
      property  DeviceCount : Integer read GetDeviceCount write FDummyInt stored False;
      property  DeviceCaps  : TMMDeviceCaps read FDeviceCaps write SetDeviceCaps stored False;
      property  Mapper      : Boolean read GetMapper write FDummyBool stored False;
      property  Active      : Boolean read GetActive write SetActive default False;
      property  DeviceId    : TMMDeviceId read FDeviceId write SetDeviceId;
      property  OnChange    : TNotifyEvent read FOnChange write FOnChange;
    end;

    {-- TMMDeviceChange -------------------------------------------------}
    TMMDeviceChange = class(TObject)
    end;

    {-- TMMAudioDevice --------------------------------------------------}
    TMMAudioDevice = class(TMMCustomAudioDevice)
    published
      property DeviceType;
    end;

    {-- EMMMCIError ---------------------------------------------------------}
    EMMMCIError = class(Exception)
    private
        FResult : MMResult;
    public
      constructor CreateRes(Res: MMResult);

      property Result: MMResult read FResult;
    end;

    {-- EMMDeviceError ------------------------------------------------------}
    EMMDeviceError = class(Exception)
    end;

function Check(MMRes: MMResult): MMResult;
function CheckExcl(MMRes: MMResult; const Excl: array of MMResult): MMResult;

{========================================================================}
implementation
{========================================================================}

{------------------------------------------------------------------------}
function Check(MMRes: MMResult): MMResult;
begin
   Result:= MMRes;
   if (MMRes <> MMSYSERR_NOERROR) then
      raise EMMMCIError.CreateRes(MMRes);
end;

{------------------------------------------------------------------------}
function CheckExcl(MMRes: MMResult; const Excl: array of MMResult): MMResult;
var
    i: Integer;
begin
    Result:= MMRes;
    for i:= Low(Excl) to High(Excl) do
        if MMRes = Excl[i] then
           Exit;
    Result:= Check(MMRes);
end;

{$IFDEF WIN32}
type
    { D3: This code rely on current Win32 API }
    TGenericCaps = packed record
       wMid           : WORD;
       wPid           : WORD;
       vDriverVersion : MMVERSION;
       szPname        : array[0..MAXPNAMELEN] of char;
    end;
{$ENDIF}

{------------------------------------------------------------------------}
function GetGenericCaps(DevType: TMMAudioDeviceType; DevId: TMMDeviceId): TGenericCaps;
begin
    { D3: This lines rely on current Win32 API}
    { Can't use array because param list of following function contains
      pointers to structures and can't be casted to Pointer }
    case DevType of
      dtMidiIn : Check(midiInGetDevCaps(DevId, @Result, SizeOf(Result)));
      dtMidiOut: Check(midiOutGetDevCaps(DevId, @Result, SizeOf(Result)));
      dtWaveIn : Check(waveInGetDevCaps(DevId, @Result, SizeOf(Result)));
      dtWaveOut: Check(waveOutGetDevCaps(DevId, @Result, SizeOf(Result)));
      dtAux    : Check(auxGetDevCaps(DevId, @Result, SizeOf(Result)));
      dtMixer  : Check(mixerGetDevCaps(DevId, @Result, SizeOf(Result)));
    end;
end;

{------------------------------------------------------------------------}
function HasMapper(DevType: TMMAudioDeviceType): Boolean;
var
   i: integer;
   Temp: TGenericCaps;
begin
    { D3: This lines rely on current Win32 API}
    { Can't use array because param list of following function contains
      pointers to structures and can't be casted to Pointer }
    i := -1;
    case DevType of
      dtMidiIn : Result := CheckExcl(midiInGetDevCaps(i, @Temp, SizeOf(Temp)),[MMSYSERR_BADDEVICEID,MMSYSERR_INVALHANDLE]) = MMSYSERR_NOERROR;
      dtMidiOut: Result := CheckExcl(midiOutGetDevCaps(i, @Temp, SizeOf(Temp)),[MMSYSERR_BADDEVICEID,MMSYSERR_INVALHANDLE]) = MMSYSERR_NOERROR;
      dtWaveIn : Result := CheckExcl(waveInGetDevCaps(i, @Temp, SizeOf(Temp)),[MMSYSERR_BADDEVICEID,MMSYSERR_INVALHANDLE]) = MMSYSERR_NOERROR;
      dtWaveOut: Result := CheckExcl(waveOutGetDevCaps(i, @Temp, SizeOf(Temp)),[MMSYSERR_BADDEVICEID,MMSYSERR_INVALHANDLE]) = MMSYSERR_NOERROR;
      dtAux    : Result := CheckExcl(auxGetDevCaps(i, @Temp, SizeOf(Temp)),[MMSYSERR_BADDEVICEID,MMSYSERR_INVALHANDLE]) = MMSYSERR_NOERROR;
      dtMixer  : Result := CheckExcl(mixerGetDevCaps(i, @Temp, SizeOf(Temp)),[MMSYSERR_BADDEVICEID,MMSYSERR_INVALHANDLE]) = MMSYSERR_NOERROR;
    else
      Result := False;
    end;
end;

{== TMMCustomAudioDevice ================================================}
procedure TMMDeviceCaps.SetDummyStr(const Value: string);
begin
  ;
end;

{-- TMMDeviceCaps -------------------------------------------------------}
procedure TMMDeviceCaps.Clear;
begin
   FManufacturerId:= 0;
   FProductId     := 0;
   FVerMajor      := 0;
   FVerMinor      := 0;
   FProductName   := '';
end;

{== TMMCustomAudioDevice ================================================}
constructor TMMCustomAudioDevice.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);

   FObservable:= TMMObservable.Create;
   FDeviceType:= defAudioDeviceType;
   FDeviceCaps:= TMMDeviceCaps.Create;
   try
      FDeviceId  := defDeviceId;
      RetrieveDeviceCaps;
   except
      FDeviceId  := InvalidId;