Delphi控件源码

开发平台：
Delphi

MMDevice.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49 (0)351-8037944              =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  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;
      RetrieveDeviceCaps;
   end;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
destructor TMMCustomAudioDevice.Destroy;
begin
   Close;
   FDeviceCaps.Free;
   FObservable.Free;
   FObservable:= nil;
   inherited Destroy;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.AddObserver(O: TMMObserver);
begin
   FObservable.AddObserver(O);
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.RemoveObserver(O: TMMObserver);
begin
   if (FObservable <> nil) then
      FObservable.RemoveObserver(O);
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.ValidDevice: Boolean;
begin
   Result:= (DeviceCount > 0) and (DeviceId <> InvalidId);
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.SetDeviceType(Value: TMMAudioDeviceType);
begin
   if (Value <> FDeviceType) then
   begin
      Close;
      FDeviceType:= Value;
      FDeviceId  := defDeviceID;
      UpdateDevice;
   end;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.SetDeviceId(Value: TMMDeviceId);
var
   wasActive: Boolean;
begin
   if (Value <> 0) and (Value <> InvalidId) and (Value <> MapperId) and
      not InRange(Value, 0, DeviceCount - 1) then
        { TODO: Should be resource id }
      raise EMMDeviceError.Create('Device id is out of range');
   if (Value <> FDeviceId) then
   begin
      wasActive:= Active;
      Close;
      FDeviceId:= Value;
      UpdateDevice;
      if wasActive then Active := True;
   end;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetDeviceCount: Integer;
type
    TGetNumProc = function: UINT; stdcall;
const
    GetNums: array[TMMAudioDeviceType] of TGetNumProc = (midiInGetNumDevs,
                                                         midiOutGetNumDevs,
                                                         waveInGetNumDevs,
                                                         waveOutGetNumDevs,
                                                         auxGetNumDevs,
                                                         mixerGetNumDevs);
begin
   Result:= GetNums[FDeviceType];
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetDevices(index: integer): string;
begin
   if (index < DeviceCount) then
       Result := GetGenericCaps(FDeviceType,index).szPName
   else
       Result := '';
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.Open;
begin
   FActive := True;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.Close;
begin
   FActive := False;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.SetActive(Value: Boolean);
begin
   if csLoading in ComponentState then
   begin
      FTempActive:= Value;
      Exit;
   end;
   if (FActive <> Value) then
   begin
      if Value then
      begin
         Close;
         Open;
      end
      else Close;
   end;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetActive: Boolean;
begin
    if csLoading in ComponentState then
        Result:= FTempActive
    else
        Result:= FActive;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.Loaded;
begin
   inherited Loaded;
   if (Active <> FTempActive) then
      Active := FTempActive;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.SetDeviceIdDirect(Value: TMMDeviceId);
begin
   FDeviceId:= Value;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.SetDeviceCaps(const Value: TMMDeviceCaps);
begin
  ;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.UpdateDevice;
begin
   RetrieveDeviceCaps;
   Changed;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.Changed;
var
   UpdChange: TMMDeviceChange;
begin
   UpdChange:= TMMDeviceChange.Create;
   try
      FObservable.NotifyObservers(UpdChange);
   finally
      UpdChange.Free;
   end;
   DoChange;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.RetrieveDeviceCaps;
var
   Caps: TGenericCaps;
begin
   with FDeviceCaps do
   if not ValidDevice then Clear
   else
   begin
      Caps           := GetGenericCaps(FDeviceType,FDeviceId);
      FManufacturerId:= Caps.wMid;
      FProductId     := Caps.wPid;
      FVerMajor      := Hi(Caps.vDriverVersion);
      FVerMinor      := Lo(Caps.vDriverVersion);
      FProductName   := StrPas(Caps.szPName);
   end;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetDeviceCapsByID(AnID: TMMDeviceId): TMMDeviceCaps;
var
  Caps: TGenericCaps;
begin
  try
    Caps := GetGenericCaps(FDeviceType, AnId);
    Result := TMMDeviceCaps.Create;
    with Result do
    begin
      FManufacturerId := Caps.wMid;
      FProductId := Caps.wPid;
      FVerMajor := Hi(Caps.vDriverVersion);
      FVerMinor := Lo(Caps.vDriverVersion);
      FProductName := StrPas(Caps.szPName);
    end;
  except
    Result := nil;
  end;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.GetDeviceList(List: TStrings; IncludeMapper: Boolean);
var
    i: Integer;
begin
   List.Clear;
   if IncludeMapper and Mapper then
      List.Add(GetGenericCaps(FDeviceType,-1).szPName);
   for i:= 0 to DeviceCount - 1 do
       List.Add(GetGenericCaps(FDeviceType,i).szPName);
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetDeviceType: TMMAudioDeviceType;
begin
   Result:= DeviceType;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
procedure TMMCustomAudioDevice.DoChange;
begin
   if Assigned(FOnChange) then
      FOnChange(Self);
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetMixerId: TMMDeviceId;
const
    MixerFlags: array[TMMAudioDeviceType] of DWORD = (MIXER_OBJECTF_MIDIIN,
                                                      MIXER_OBJECTF_MIDIOUT,
                                                      MIXER_OBJECTF_WAVEIN,
                                                      MIXER_OBJECTF_WAVEOUT,
                                                      MIXER_OBJECTF_AUX,
                                                      MIXER_OBJECTF_MIXER);
var
    Res: DWORD;
begin
   CheckExcl(mixerGetId(DeviceId, Res, MixerFlags[DeviceType]),[MMSYSERR_NODRIVER]);
   if integer(Res) = -1 then
    Result := InvalidId
   else
    Result := Res;
end;
{-- TMMCustomAudioDevice ------------------------------------------------}
function TMMCustomAudioDevice.GetMapper: Boolean;
begin
    Result := HasMapper(DeviceType);
end;
{== EMMMCIError =========================================================}
constructor EMMMCIError.CreateRes(Res: MMResult);
var
   Buf: array[0..1023] of char;
begin
   FResult := Res;
   if mciGetErrorString(Res, @Buf, SizeOf(Buf) - 1) then
      inherited Create(StrPas(Buf))
   else
      inherited CreateFmt('MMSystem error: %d', [Res]);
end;
end.

						