{**************************************************************************************************} { } { Project JEDI Code Library (JCL) } { } { The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); } { you may not use this file except in compliance with the License. You may obtain a copy of the } { License at http://www.mozilla.org/MPL/ } { } { Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF } { ANY KIND, either express or implied. See the License for the specific language governing rights } { and limitations under the License. } { } { The Original Code is JclMultimedia.pas. } { } { The Initial Developers of the Original Code are Marcel van Brakel and Bernhard Berger. } { Portions created by these individuals are Copyright (C) of these individuals. } { All Rights Reserved. } { } { Contributor(s): } { Marcel van Brakel } { Robert Marquardt (marquardt) } { Robert Rossmair (rrossmair) } { Matthias Thoma (mthoma) } { Petr Vones (pvones) } { } {**************************************************************************************************} { } { Contains a high performance timer based on the MultiMedia API and a routine to open or close the } { CD-ROM drive. } { } {**************************************************************************************************} // Last modified: $Date: 2005/12/12 21:54:10 $ // For history see end of file unit JclMultimedia; {$I jcl.inc} interface uses Windows, Classes, MMSystem, Contnrs, JclBase, JclSynch, JclStrings; type {$IFDEF FPC} // declarations missing from mmsystem.pp // see also implementation section TTimeCaps = TIMECAPS; TMixerControl = MIXERCONTROL; TMixerCaps = MIXERCAPS; TMixerLine = MIXERLINE; TMCI_Open_Parms = MCI_OPEN_PARMS; {$ENDIF FPC} // Multimedia timer TMmTimerKind = (tkOneShot, tkPeriodic); TMmNotificationKind = (nkCallback, nkSetEvent, nkPulseEvent); TJclMultimediaTimer = class(TObject) private FEvent: TJclEvent; FKind: TMmTimerKind; FNotification: TMmNotificationKind; FOnTimer: TNotifyEvent; FPeriod: Cardinal; FStartTime: Cardinal; FTimeCaps: TTimeCaps; FTimerId: Cardinal; function GetMinMaxPeriod(Index: Integer): Cardinal; procedure SetPeriod(Value: Cardinal); protected procedure Timer(Id: Cardinal); virtual; public constructor Create(Kind: TMmTimerKind; Notification: TMmNotificationKind); destructor Destroy; override; class function GetTime: Cardinal; class function BeginPeriod(const Period: Cardinal): Boolean; { TODO -cHelp : Doc } class function EndPeriod(const Period: Cardinal): Boolean; { TODO -cHelp : Doc } procedure BeginTimer(const Delay, Resolution: Cardinal); procedure EndTimer; function Elapsed(const Update: Boolean): Cardinal; function WaitFor(const TimeOut: Cardinal): TJclWaitResult; property Event: TJclEvent read FEvent; property Kind: TMmTimerKind read FKind; property MaxPeriod: Cardinal index 0 read GetMinMaxPeriod; property MinPeriod: Cardinal index 1 read GetMinMaxPeriod; property Notification: TMmNotificationKind read FNotification; property OnTimer: TNotifyEvent read FOnTimer write FOnTimer; property Period: Cardinal read FPeriod write SetPeriod; end; EJclMmTimerError = class(EJclError); // Audio Mixer { TODO -cDoc : mixer API wrapper code. Author: Petr Vones } EJclMixerError = class(EJclError); TJclMixerDevice = class; TJclMixerLine = class; TJclMixerDestination = class; TJclMixerLineControl = class(TObject) private FControlInfo: TMixerControl; FIsList: Boolean; FIsMultiple: Boolean; FIsUniform: Boolean; FListText: TStringList; FMixerLine: TJclMixerLine; function GetIsDisabled: Boolean; function GetID: DWORD; function GetListText: TStrings; function GetName: string; function GetUniformValue: Cardinal; function GetValue: TDynCardinalArray; function GetValueString: string; procedure SetUniformValue(const Value: Cardinal); procedure SetValue(const Value: TDynCardinalArray); protected constructor Create(AMixerLine: TJclMixerLine; const AControlInfo: TMixerControl); procedure PrepareControlDetailsStruc(var ControlDetails: TMixerControlDetails; AUniform, AMultiple: Boolean); public destructor Destroy; override; function FormatValue(AValue: Cardinal): string; property ControlInfo: TMixerControl read FControlInfo; property ID: DWORD read GetID; property IsDisabled: Boolean read GetIsDisabled; property IsList: Boolean read FIsList; property IsMultiple: Boolean read FIsMultiple; property IsUniform: Boolean read FIsUniform; property ListText: TStrings read GetListText; property MixerLine: TJclMixerLine read FMixerLine; property Name: string read GetName; property UniformValue: Cardinal read GetUniformValue write SetUniformValue; property Value: TDynCardinalArray read GetValue write SetValue; property ValueString: string read GetValueString; end; TJclMixerLine = class(TObject) private FLineControls: TObjectList; FLineInfo: TMixerLine; FMixerDevice: TJclMixerDevice; function GetComponentString: string; function GetLineControlByType(ControlType: DWORD): TJclMixerLineControl; function GetLineControlCount: Integer; function GetLineControls(Index: Integer): TJclMixerLineControl; function GetHasControlType(ControlType: DWORD): Boolean; function GetID: DWORD; function GetName: string; protected procedure BuildLineControls; constructor Create(AMixerDevice: TJclMixerDevice); public destructor Destroy; override; class function ComponentTypeToString(const ComponentType: DWORD): string; property ComponentString: string read GetComponentString; property HasControlType[ControlType: DWORD]: Boolean read GetHasControlType; property ID: DWORD read GetID; property LineControlByType[ControlType: DWORD]: TJclMixerLineControl read GetLineControlByType; property LineControls[Index: Integer]: TJclMixerLineControl read GetLineControls; default; property LineControlCount: Integer read GetLineControlCount; property LineInfo: TMixerLine read FLineInfo; property Name: string read GetName; property MixerDevice: TJclMixerDevice read FMixerDevice; end; TJclMixerSource = class(TJclMixerLine) private FMixerDestination: TJclMixerDestination; protected constructor Create(AMixerDestination: TJclMixerDestination; ASourceIndex: Cardinal); public property MixerDestination: TJclMixerDestination read FMixerDestination; end; TJclMixerDestination = class(TJclMixerLine) private FSources: TObjectList; function GetSourceCount: Integer; function GetSources(Index: Integer): TJclMixerSource; protected constructor Create(AMixerDevice: TJclMixerDevice; ADestinationIndex: Cardinal); procedure BuildSources; public destructor Destroy; override; property Sources[Index: Integer]: TJclMixerSource read GetSources; default; property SourceCount: Integer read GetSourceCount; end; TJclMixerDevice = class(TObject) private FCapabilities: TMixerCaps; FDestinations: TObjectList; FDeviceIndex: Cardinal; FHandle: HMIXER; FLines: TList; function GetProductName: string; function GetDestinationCount: Integer; function GetDestinations(Index: Integer): TJclMixerDestination; function GetLineCount: Integer; function GetLines(Index: Integer): TJclMixerLine; function GetLineByComponentType(ComponentType: DWORD): TJclMixerLine; function GetLineByID(LineID: DWORD): TJclMixerLine; function GetLineControlByID(ControlID: DWORD): TJclMixerLineControl; function GetLineUniformValue(ComponentType, ControlType: DWORD): Cardinal; procedure SetLineUniformValue(ComponentType, ControlType: DWORD; const Value: Cardinal); protected constructor Create(ADeviceIndex: Cardinal; ACallBackWnd: THandle); procedure BuildDestinations; procedure BuildLines; procedure Close; procedure Open(ACallBackWnd: THandle); public destructor Destroy; override; function FindLineControl(ComponentType, ControlType: DWORD): TJclMixerLineControl; property Capabilities: TMixerCaps read FCapabilities; property DeviceIndex: Cardinal read FDeviceIndex; property Destinations[Index: Integer]: TJclMixerDestination read GetDestinations; default; property DestinationCount: Integer read GetDestinationCount; property Handle: HMIXER read FHandle; property LineByID[LineID: DWORD]: TJclMixerLine read GetLineByID; property LineByComponentType[ComponentType: DWORD]: TJclMixerLine read GetLineByComponentType; property Lines[Index: Integer]: TJclMixerLine read GetLines; property LineCount: Integer read GetLineCount; property LineControlByID[ControlID: DWORD]: TJclMixerLineControl read GetLineControlByID; property LineUniformValue[ComponentType, ControlType: DWORD]: Cardinal read GetLineUniformValue write SetLineUniformValue; property ProductName: string read GetProductName; end; TJclMixer = class(TObject) private FCallbackWnd: THandle; FDeviceList: TObjectList; function GetDeviceCount: Integer; function GetDevices(Index: Integer): TJclMixerDevice; function GetFirstDevice: TJclMixerDevice; function GetLineMute(ComponentType: Integer): Boolean; function GetLineVolume(ComponentType: Integer): Cardinal; function GetLineByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLine; function GetLineControlByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLineControl; procedure SetLineMute(ComponentType: Integer; const Value: Boolean); procedure SetLineVolume(ComponentType: Integer; const Value: Cardinal); protected procedure BuildDevices; public constructor Create(ACallBackWnd: THandle = 0); destructor Destroy; override; property CallbackWnd: THandle read FCallbackWnd; property Devices[Index: Integer]: TJclMixerDevice read GetDevices; default; property DeviceCount: Integer read GetDeviceCount; property FirstDevice: TJclMixerDevice read GetFirstDevice; property LineByID[MixerHandle: HMIXER; LineID: DWORD]: TJclMixerLine read GetLineByID; property LineControlByID[MixerHandle: HMIXER; LineID: DWORD]: TJclMixerLineControl read GetLineControlByID; property LineMute[ComponentType: Integer]: Boolean read GetLineMute write SetLineMute; property LineVolume[ComponentType: Integer]: Cardinal read GetLineVolume write SetLineVolume; property SpeakersMute: Boolean index MIXERLINE_COMPONENTTYPE_DST_SPEAKERS read GetLineMute write SetLineMute; property SpeakersVolume: Cardinal index MIXERLINE_COMPONENTTYPE_DST_SPEAKERS read GetLineVolume write SetLineVolume; end; function MixerLeftRightToArray(Left, Right: Cardinal): TDynCardinalArray; type // MCI Error checking EJclMciError = class(EJclError) private FMciErrorNo: DWORD; FMciErrorMsg: string; public constructor Create(MciErrNo: MCIERROR; const Msg: string); constructor CreateFmt(MciErrNo: MCIERROR; const Msg: string; const Args: array of const); constructor CreateRes(MciErrNo: MCIERROR; Ident: Integer); property MciErrorNo: DWORD read FMciErrorNo; property MciErrorMsg: string read FMciErrorMsg; end; function MMCheck(const MciError: MCIERROR; const Msg: string = ''): MCIERROR; function GetMciErrorMessage(const MciErrNo: MCIERROR): string; // CD Drive MCI Routines function OpenCdMciDevice(var OpenParams: TMCI_Open_Parms; Drive: Char = #0): MCIERROR; function CloseCdMciDevice(var OpenParams: TMCI_Open_Parms): MCIERROR; // CD Drive specific routines procedure OpenCloseCdDrive(OpenMode: Boolean; Drive: Char = #0); function IsMediaPresentInDrive(Drive: Char = #0): Boolean; type TJclCdMediaInfo = (miProduct, miIdentity, miUPC); TJclCdTrackType = (ttAudio, ttOther); TJclCdTrackInfo = record Minute: Byte; Second: Byte; TrackType: TJclCdTrackType; end; TJclCdTrackInfoArray = array of TJclCdTrackInfo; function GetCdInfo(InfoType: TJclCdMediaInfo; Drive: Char = #0): string; function GetCDAudioTrackList(var TrackList: TJclCdTrackInfoArray; Drive: Char = #0): TJclCdTrackInfo; overload; function GetCDAudioTrackList(TrackList: TStrings; IncludeTrackType: Boolean = False; Drive: Char = #0): string; overload; implementation uses SysUtils, JclResources, JclSysUtils; { TODO : move to JclWin32? } {$IFDEF FPC} // declarations missing from mmsystem.pp const mmsyst = 'winmm.dll'; type TFNTimeCallBack = procedure(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD) stdcall; PMixerControlDetailsListText = ^TMixerControlDetailsListText; TMixerControlDetailsListText = MIXERCONTROLDETAILS_LISTTEXTA; TMixerLineControlsA = MIXERLINECONTROLSA; TMixerLineControls = TMixerLineControlsA; TMCI_Status_Parms = MCI_STATUS_PARMS; TMCI_Info_Parms = MCI_INFO_PARMS; TMCI_Set_Parms = MCI_SET_PARMS; function mixerSetControlDetails(hmxobj: HMIXEROBJ; pmxcd: PMixerControlDetails; fdwDetails: DWORD): MMRESULT; stdcall; external mmsyst name 'mixerSetControlDetails'; {$ENDIF FPC} //=== { TJclMultimediaTimer } ================================================ constructor TJclMultimediaTimer.Create(Kind: TMmTimerKind; Notification: TMmNotificationKind); begin FKind := Kind; FNotification := Notification; FPeriod := 0; FTimerID := 0; FEvent := nil; FillChar(FTimeCaps, SizeOf(FTimeCaps), #0); if timeGetDevCaps(@FTimeCaps, SizeOf(FTimeCaps)) = TIMERR_STRUCT then raise EJclMmTimerError.CreateRes(@RsMmTimerGetCaps); FPeriod := FTimeCaps.wPeriodMin; if Notification <> nkCallback then FEvent := TJclEvent.Create(nil, Notification = nkSetEvent, False, ''); end; destructor TJclMultimediaTimer.Destroy; begin EndTimer; FreeAndNil(FEvent); FOnTimer := nil; inherited Destroy; end; procedure MmTimerCallback(TimerId, Msg: Cardinal; User, dw1, dw2: DWORD); stdcall; begin TJclMultimediaTimer(User).Timer(TimerId); end; class function TJclMultimediaTimer.BeginPeriod(const Period: Cardinal): Boolean; begin Result := timeBeginPeriod(Period) = TIMERR_NOERROR; end; procedure TJclMultimediaTimer.BeginTimer(const Delay, Resolution: Cardinal); var Event: Cardinal; TimerCallback: TFNTimeCallBack; begin if FTimerId <> 0 then raise EJclMmTimerError.CreateRes(@RsMmTimerActive); Event := 0; TimerCallback := nil; case FKind of tkPeriodic: Event := TIME_PERIODIC; tkOneShot: Event := TIME_ONESHOT; end; case FNotification of nkCallback: begin Event := Event or TIME_CALLBACK_FUNCTION; TimerCallback := @MmTimerCallback; end; nkSetEvent: begin Event := Event or TIME_CALLBACK_EVENT_SET; TimerCallback := TFNTimeCallback(FEvent.Handle); end; nkPulseEvent: begin Event := Event or TIME_CALLBACK_EVENT_PULSE; TimerCallback := TFNTimeCallback(FEvent.Handle); end; end; FStartTime := GetTime; if timeBeginPeriod(FPeriod) = TIMERR_NOERROR then FTimerId := timeSetEvent(Delay, Resolution, TimerCallBack, DWORD(Self), Event); if FTimerId = 0 then raise EJclMmTimerError.CreateRes(@RsMmSetEvent); end; function TJclMultimediaTimer.Elapsed(const Update: Boolean): Cardinal; var CurrentTime: Cardinal; begin if FTimerId = 0 then Result := 0 else begin CurrentTime := GetTime; if CurrentTime >= FStartTime then Result := CurrentTime - FStartTime else Result := (High(Cardinal) - FStartTime) + CurrentTime; if Update then FStartTime := CurrentTime; end; end; class function TJclMultimediaTimer.EndPeriod(const Period: Cardinal): Boolean; begin Result := timeEndPeriod(Period) = TIMERR_NOERROR; end; procedure TJclMultimediaTimer.EndTimer; begin if FTimerId <> 0 then begin if FKind = tkPeriodic then timeKillEvent(FTimerId); timeEndPeriod(FPeriod); FTimerId := 0; end; end; function TJclMultimediaTimer.GetMinMaxPeriod(Index: Integer): Cardinal; begin case Index of 0: Result := FTimeCaps.wPeriodMax; 1: Result := FTimeCaps.wPeriodMin; else Result := 0; end; end; class function TJclMultimediaTimer.GetTime: Cardinal; begin Result := timeGetTime; end; procedure TJclMultimediaTimer.SetPeriod(Value: Cardinal); begin if FTimerId <> 0 then raise EJclMmTimerError.CreateRes(@RsMmTimerActive); FPeriod := Value; end; { TODO -cHelp : Applications should not call any system-defined functions from inside a callback function, except for PostMessage, timeGetSystemTime, timeGetTime, timeSetEvent, timeKillEvent, midiOutShortMsg, midiOutLongMsg, and OutputDebugString. } procedure TJclMultimediaTimer.Timer(Id: Cardinal); begin { TODO : A exception in the callbacl i very likely very critically } if Id <> FTimerId then raise EJclMmTimerError.CreateRes(@RsMmInconsistentId); if Assigned(FOnTimer) then FOnTimer(Self); end; function TJclMultimediaTimer.WaitFor(const TimeOut: Cardinal): TJclWaitResult; begin if FNotification = nkCallback then Result := wrError else Result := FEvent.WaitFor(TimeOut); end; //=== { TJclMixerLineControl } =============================================== function MixerLeftRightToArray(Left, Right: Cardinal): TDynCardinalArray; begin SetLength(Result, 2); Result[0] := Left; Result[1] := Right; end; constructor TJclMixerLineControl.Create(AMixerLine: TJclMixerLine; const AControlInfo: TMixerControl); begin FControlInfo := AControlInfo; FMixerLine := AMixerLine; FIsList := (ControlInfo.dwControlType and MIXERCONTROL_CT_CLASS_MASK) = MIXERCONTROL_CT_CLASS_LIST; FIsMultiple := FControlInfo.fdwControl and MIXERCONTROL_CONTROLF_MULTIPLE <> 0; FIsUniform := FControlInfo.fdwControl and MIXERCONTROL_CONTROLF_UNIFORM <> 0; end; destructor TJclMixerLineControl.Destroy; begin FreeAndNil(FListText); inherited Destroy; end; function TJclMixerLineControl.FormatValue(AValue: Cardinal): string; begin case FControlInfo.dwControlType and MIXERCONTROL_CT_UNITS_MASK of MIXERCONTROL_CT_UNITS_BOOLEAN: Result := BooleanToStr(Boolean(AValue)); MIXERCONTROL_CT_UNITS_SIGNED: Result := Format('%d', [AValue]); MIXERCONTROL_CT_UNITS_UNSIGNED: Result := Format('%u', [AValue]); MIXERCONTROL_CT_UNITS_DECIBELS: Result := Format('%.1fdB', [AValue / 10]); MIXERCONTROL_CT_UNITS_PERCENT: Result := Format('%.1f%%', [AValue / 10]); else Result := ''; end; end; function TJclMixerLineControl.GetID: DWORD; begin Result := ControlInfo.dwControlID; end; function TJclMixerLineControl.GetIsDisabled: Boolean; begin Result := FControlInfo.fdwControl and MIXERCONTROL_CONTROLF_DISABLED <> 0; end; function TJclMixerLineControl.GetListText: TStrings; var ControlDetails: TMixerControlDetails; ListTexts, P: PMixerControlDetailsListText; I: Cardinal; begin if FListText = nil then begin FListText := TStringList.Create; if IsMultiple and IsList then begin PrepareControlDetailsStruc(ControlDetails, True, IsMultiple); ControlDetails.cbDetails := SizeOf(TMixerControlDetailsListText); GetMem(ListTexts, SizeOf(TMixerControlDetailsListText) * ControlDetails.cMultipleItems); try ControlDetails.paDetails := ListTexts; if mixerGetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_LISTTEXT) = MMSYSERR_NOERROR then begin P := ListTexts; for I := 1 to ControlDetails.cMultipleItems do begin FListText.AddObject(P^.szName, Pointer(P^.dwParam1)); Inc(P); end; end; finally FreeMem(ListTexts); end; end; end; Result := FListText; end; function TJclMixerLineControl.GetName: string; begin Result := FControlInfo.szName; end; function TJclMixerLineControl.GetUniformValue: Cardinal; var ControlDetails: TMixerControlDetails; begin PrepareControlDetailsStruc(ControlDetails, True, False); ControlDetails.cbDetails := SizeOf(Cardinal); ControlDetails.paDetails := @Result; MMCheck(mixerGetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE)); end; function TJclMixerLineControl.GetValue: TDynCardinalArray; var ControlDetails: TMixerControlDetails; ItemCount: Cardinal; begin PrepareControlDetailsStruc(ControlDetails, IsUniform, IsMultiple); if IsUniform then ItemCount := 1 else ItemCount := ControlDetails.cChannels; if IsMultiple then ItemCount := ItemCount * ControlDetails.cMultipleItems; SetLength(Result, ItemCount); ControlDetails.cbDetails := SizeOf(Cardinal); ControlDetails.paDetails := @Result[0]; MMCheck(mixerGetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE)); end; function TJclMixerLineControl.GetValueString: string; var TempValue: TDynCardinalArray; I: Integer; begin TempValue := Value; Result := ''; for I := Low(TempValue) to High(TempValue) do Result := Result + ',' + FormatValue(TempValue[I]); Delete(Result, 1, 1); end; procedure TJclMixerLineControl.PrepareControlDetailsStruc(var ControlDetails: TMixerControlDetails; AUniform, AMultiple: Boolean); begin FillChar(ControlDetails, SizeOf(ControlDetails), 0); ControlDetails.cbStruct := SizeOf(ControlDetails); ControlDetails.dwControlID := FControlInfo.dwControlID; if AUniform then ControlDetails.cChannels := MIXERCONTROL_CONTROLF_UNIFORM else ControlDetails.cChannels := MixerLine.LineInfo.cChannels; if AMultiple then ControlDetails.cMultipleItems := FControlInfo.cMultipleItems; end; procedure TJclMixerLineControl.SetUniformValue(const Value: Cardinal); var ControlDetails: TMixerControlDetails; begin PrepareControlDetailsStruc(ControlDetails, True, False); ControlDetails.cbDetails := SizeOf(Cardinal); ControlDetails.paDetails := @Value; MMCheck(mixerSetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE)); end; procedure TJclMixerLineControl.SetValue(const Value: TDynCardinalArray); var ControlDetails: TMixerControlDetails; {$IFDEF ASSERTIONS_ON} ItemCount: Cardinal; {$ENDIF ASSERTIONS_ON} begin PrepareControlDetailsStruc(ControlDetails, IsUniform, IsMultiple); {$IFDEF ASSERTIONS_ON} if IsUniform then ItemCount := 1 else ItemCount := ControlDetails.cChannels; if IsMultiple then ItemCount := ItemCount * ControlDetails.cMultipleItems; Assert(ItemCount = Cardinal(Length(Value))); {$ENDIF ASSERTIONS_ON} ControlDetails.cbDetails := SizeOf(Cardinal); ControlDetails.paDetails := @Value[0]; MMCheck(mixerSetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE)); end; //=== { TJclMixerLine } ====================================================== function MixerLineCompareID(Item1, Item2: Pointer): Integer; begin Result := Integer(TJclMixerLine(Item1).ID) - Integer(TJclMixerLine(Item2).ID); end; function MixerLineSearchID(Param: Pointer; ItemIndex: Integer; const Value): Integer; begin Result := Integer(TJclMixerDevice(Param).Lines[ItemIndex].ID) - Integer(Value); end; constructor TJclMixerLine.Create(AMixerDevice: TJclMixerDevice); begin FMixerDevice := AMixerDevice; FLineControls := TObjectList.Create; end; destructor TJclMixerLine.Destroy; begin FreeAndNil(FLineControls); inherited Destroy; end; procedure TJclMixerLine.BuildLineControls; var MixerControls: TMixerLineControls; Controls, P: PMixerControl; I: Cardinal; Item: TJclMixerLineControl; begin GetMem(Controls, SizeOf(TMixerControl) * FLineInfo.cControls); try MixerControls.cbStruct := SizeOf(MixerControls); MixerControls.dwLineID := FLineInfo.dwLineID; MixerControls.cControls := FLineInfo.cControls; MixerControls.cbmxctrl := SizeOf(TMixerControl); MixerControls.pamxctrl := Controls; if mixerGetLineControls(FMixerDevice.Handle, @MixerControls, MIXER_GETLINECONTROLSF_ALL) = MMSYSERR_NOERROR then begin P := Controls; for I := 1 to FLineInfo.cControls do begin Item := TJclMixerLineControl.Create(Self, P^); FLineControls.Add(Item); Inc(P); end; end; finally FreeMem(Controls); end; end; class function TJclMixerLine.ComponentTypeToString(const ComponentType: DWORD): string; begin case ComponentType of MIXERLINE_COMPONENTTYPE_DST_UNDEFINED: Result := RsMmMixerUndefined; MIXERLINE_COMPONENTTYPE_DST_DIGITAL, MIXERLINE_COMPONENTTYPE_SRC_DIGITAL: Result := RsMmMixerDigital; MIXERLINE_COMPONENTTYPE_DST_LINE, MIXERLINE_COMPONENTTYPE_SRC_LINE: Result := RsMmMixerLine; MIXERLINE_COMPONENTTYPE_DST_MONITOR: Result := RsMmMixerMonitor; MIXERLINE_COMPONENTTYPE_DST_SPEAKERS: Result := RsMmMixerSpeakers; MIXERLINE_COMPONENTTYPE_DST_HEADPHONES: Result := RsMmMixerHeadphones; MIXERLINE_COMPONENTTYPE_DST_TELEPHONE, MIXERLINE_COMPONENTTYPE_SRC_TELEPHONE: Result := RsMmMixerTelephone; MIXERLINE_COMPONENTTYPE_DST_WAVEIN: Result := RsMmMixerWaveIn; MIXERLINE_COMPONENTTYPE_DST_VOICEIN: Result := RsMmMixerVoiceIn; MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE: Result := RsMmMixerMicrophone; MIXERLINE_COMPONENTTYPE_SRC_SYNTHESIZER: Result := RsMmMixerSynthesizer; MIXERLINE_COMPONENTTYPE_SRC_COMPACTDISC: Result := RsMmMixerCompactDisc; MIXERLINE_COMPONENTTYPE_SRC_PCSPEAKER: Result := RsMmMixerPcSpeaker; MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT: Result := RsMmMixerWaveOut; MIXERLINE_COMPONENTTYPE_SRC_AUXILIARY: Result := RsMmMixerAuxiliary; MIXERLINE_COMPONENTTYPE_SRC_ANALOG: Result := RsMmMixerAnalog; else Result := ''; end; end; function TJclMixerLine.GetComponentString: string; begin Result := ComponentTypeToString(FLineInfo.dwComponentType); end; function TJclMixerLine.GetHasControlType(ControlType: DWORD): Boolean; begin Result := LineControlByType[ControlType] <> nil; end; function TJclMixerLine.GetID: DWORD; begin Result := LineInfo.dwLineID; end; function TJclMixerLine.GetLineControlByType(ControlType: DWORD): TJclMixerLineControl; var I: Integer; begin Result := nil; for I := 0 to LineControlCount - 1 do if LineControls[I].ControlInfo.dwControlType = ControlType then begin Result := LineControls[I]; Break; end; end; function TJclMixerLine.GetLineControlCount: Integer; begin Result := FLineControls.Count; if Result = 0 then begin BuildLineControls; Result := FLineControls.Count; end; end; function TJclMixerLine.GetLineControls(Index: Integer): TJclMixerLineControl; begin Result := TJclMixerLineControl(FLineControls[Index]); end; function TJclMixerLine.GetName: string; begin Result := FLineInfo.szName; end; //=== { TJclMixerSource } ==================================================== constructor TJclMixerSource.Create(AMixerDestination: TJclMixerDestination; ASourceIndex: Cardinal); begin inherited Create(AMixerDestination.MixerDevice); FMixerDestination := AMixerDestination; FLineInfo.cbStruct := SizeOf(FLineInfo); FLineInfo.dwDestination := FMixerDestination.LineInfo.dwDestination; FLineInfo.dwSource := ASourceIndex; MMCheck(mixerGetLineInfo(FMixerDestination.MixerDevice.Handle, @FLineInfo, MIXER_GETLINEINFOF_SOURCE)); end; //=== { TJclMixerDestination } =============================================== constructor TJclMixerDestination.Create(AMixerDevice: TJclMixerDevice; ADestinationIndex: Cardinal); begin inherited Create(AMixerDevice); FLineInfo.cbStruct := SizeOf(FLineInfo); FLineInfo.dwDestination := ADestinationIndex; MMCheck(mixerGetLineInfo(AMixerDevice.Handle, @FLineInfo, MIXER_GETLINEINFOF_DESTINATION)); FSources := TObjectList.Create; end; destructor TJclMixerDestination.Destroy; begin FreeAndNil(FSources); inherited Destroy; end; procedure TJclMixerDestination.BuildSources; var I: Cardinal; Item: TJclMixerSource; begin for I := 1 to LineInfo.cConnections do begin Item := TJclMixerSource.Create(Self, I - 1); FSources.Add(Item); end; end; function TJclMixerDestination.GetSourceCount: Integer; begin Result := FSources.Count; if Result = 0 then begin BuildSources; Result := FSources.Count; end; end; function TJclMixerDestination.GetSources(Index: Integer): TJclMixerSource; begin Result := TJclMixerSource(FSources[Index]); end; //=== { TJclMixerDevice } ==================================================== constructor TJclMixerDevice.Create(ADeviceIndex: Cardinal; ACallBackWnd: THandle); begin FDeviceIndex := ADeviceIndex; FHandle := -1; FDestinations := TObjectList.Create; FLines := TList.Create; MMCheck(mixerGetDevCaps(ADeviceIndex, @FCapabilities, SizeOf(FCapabilities))); Open(ACallBackWnd); BuildDestinations; end; destructor TJclMixerDevice.Destroy; begin Close; FreeAndNil(FDestinations); FreeAndNil(FLines); inherited Destroy; end; procedure TJclMixerDevice.BuildDestinations; var I: Cardinal; Item: TJclMixerDestination; begin for I := 1 to FCapabilities.cDestinations do begin Item := TJclMixerDestination.Create(Self, I - 1); FDestinations.Add(Item); end; end; procedure TJclMixerDevice.BuildLines; var D, I: Integer; Dest: TJclMixerDestination; begin for D := 0 to DestinationCount - 1 do begin Dest := Destinations[D]; FLines.Add(Dest); for I := 0 to Dest.SourceCount - 1 do FLines.Add(Dest.Sources[I]); end; FLines.Sort(MixerLineCompareID); end; procedure TJclMixerDevice.Close; begin if FHandle <> -1 then begin mixerClose(FHandle); FHandle := -1; end; end; function TJclMixerDevice.FindLineControl(ComponentType, ControlType: DWORD): TJclMixerLineControl; var TempLine: TJclMixerLine; begin Result := nil; TempLine := LineByComponentType[ComponentType]; if TempLine <> nil then Result := TempLine.LineControlByType[ControlType]; end; function TJclMixerDevice.GetDestinationCount: Integer; begin Result := FDestinations.Count; end; function TJclMixerDevice.GetDestinations(Index: Integer): TJclMixerDestination; begin Result := TJclMixerDestination(FDestinations[Index]); end; function TJclMixerDevice.GetLineByComponentType(ComponentType: DWORD): TJclMixerLine; var I: Integer; begin Result := nil; for I := 0 to LineCount - 1 do if Lines[I].LineInfo.dwComponentType = ComponentType then begin Result := Lines[I]; Break; end; end; function TJclMixerDevice.GetLineByID(LineID: DWORD): TJclMixerLine; var I: Integer; begin I := SearchSortedUntyped(Self, LineCount, MixerLineSearchID, Pointer(LineID)); if I = -1 then Result := nil else Result := Lines[I]; end; function TJclMixerDevice.GetLineControlByID(ControlID: DWORD): TJclMixerLineControl; var L, C: Integer; TempLine: TJclMixerLine; begin Result := nil; for L := 0 to LineCount - 1 do begin TempLine := Lines[L]; for C := 0 to TempLine.LineControlCount - 1 do if TempLine.LineControls[C].ID = ControlID then begin Result := TempLine.LineControls[C]; Break; end; end; end; function TJclMixerDevice.GetLineCount: Integer; begin Result := FLines.Count; if Result = 0 then begin BuildLines; Result := FLines.Count; end; end; function TJclMixerDevice.GetLines(Index: Integer): TJclMixerLine; begin Result := TJclMixerLine(FLines[Index]); end; function TJclMixerDevice.GetLineUniformValue(ComponentType, ControlType: DWORD): Cardinal; var LineControl: TJclMixerLineControl; begin LineControl := FindLineControl(ComponentType, ControlType); if LineControl <> nil then Result := LineControl.UniformValue else Result := 0; end; function TJclMixerDevice.GetProductName: string; begin Result := FCapabilities.szPname; end; procedure TJclMixerDevice.Open(ACallBackWnd: THandle); var Flags: DWORD; begin if FHandle = -1 then begin Flags := MIXER_OBJECTF_HMIXER; if ACallBackWnd <> 0 then Inc(Flags, CALLBACK_WINDOW); MMCheck(mixerOpen(@FHandle, DeviceIndex, ACallBackWnd, 0, Flags)); end; end; procedure TJclMixerDevice.SetLineUniformValue(ComponentType, ControlType: DWORD; const Value: Cardinal); var LineControl: TJclMixerLineControl; begin LineControl := FindLineControl(ComponentType, ControlType); if LineControl <> nil then LineControl.UniformValue := Value else raise EJclMixerError.CreateResFmt(@RsMmMixerCtlNotFound, [TJclMixerLine.ComponentTypeToString(ComponentType), ControlType]); end; //=== { TJclMixer } ========================================================== constructor TJclMixer.Create(ACallBackWnd: THandle); begin FDeviceList := TObjectList.Create; FCallbackWnd := ACallBackWnd; BuildDevices; end; destructor TJclMixer.Destroy; begin FreeAndNil(FDeviceList); inherited Destroy; end; procedure TJclMixer.BuildDevices; var I: Cardinal; Item: TJclMixerDevice; begin for I := 1 to mixerGetNumDevs do begin Item := TJclMixerDevice.Create(I - 1, FCallbackWnd); FDeviceList.Add(Item); end; end; function TJclMixer.GetDeviceCount: Integer; begin Result := FDeviceList.Count; end; function TJclMixer.GetDevices(Index: Integer): TJclMixerDevice; begin Result := TJclMixerDevice(FDeviceList.Items[Index]); end; function TJclMixer.GetFirstDevice: TJclMixerDevice; begin if DeviceCount = 0 then raise EJclMixerError.CreateRes(@RsMmMixerNoDevices); Result := Devices[0]; end; function TJclMixer.GetLineByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLine; var I: Integer; TempDevice: TJclMixerDevice; begin Result := nil; for I := 0 to DeviceCount - 1 do begin TempDevice := Devices[I]; if TempDevice.Handle = MixerHandle then begin Result := TempDevice.LineByID[LineID]; if Result <> nil then Break; end; end; end; function TJclMixer.GetLineControlByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLineControl; var I: Integer; TempDevice: TJclMixerDevice; begin Result := nil; for I := 0 to DeviceCount - 1 do begin TempDevice := Devices[I]; if TempDevice.Handle = MixerHandle then begin Result := TempDevice.LineControlByID[LineID]; if Result <> nil then Break; end; end; end; function TJclMixer.GetLineMute(ComponentType: Integer): Boolean; begin Result := Boolean(FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_MUTE]); end; function TJclMixer.GetLineVolume(ComponentType: Integer): Cardinal; begin Result := FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_VOLUME]; end; procedure TJclMixer.SetLineMute(ComponentType: Integer; const Value: Boolean); begin FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_MUTE] := Cardinal(Value); end; procedure TJclMixer.SetLineVolume(ComponentType: Integer; const Value: Cardinal); begin FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_VOLUME] := Value; end; //=== { EJclMciError } ======================================================= constructor EJclMciError.Create(MciErrNo: MCIERROR; const Msg: string); begin FMciErrorNo := MciErrNo; FMciErrorMsg := GetMciErrorMessage(MciErrNo); inherited Create(Msg + AnsiLineBreak + RsMmMciErrorPrefix + FMciErrorMsg); end; constructor EJclMciError.CreateFmt(MciErrNo: MCIERROR; const Msg: string; const Args: array of const); begin FMciErrorNo := MciErrNo; FMciErrorMsg := GetMciErrorMessage(MciErrNo); inherited CreateFmt(Msg + AnsiLineBreak + RsMmMciErrorPrefix + FMciErrorMsg, Args); end; constructor EJclMciError.CreateRes(MciErrNo: MCIERROR; Ident: Integer); begin FMciErrorNo := MciErrNo; FMciErrorMsg := GetMciErrorMessage(MciErrNo); inherited Create(LoadStr(Ident)+ AnsiLineBreak + RsMmMciErrorPrefix + FMciErrorMsg); end; function GetMciErrorMessage(const MciErrNo: MCIERROR): string; var Buffer: array [0..MMSystem.MAXERRORLENGTH - 1] of Char; begin if mciGetErrorString(MciErrNo, Buffer, SizeOf(Buffer)) then Result := Buffer else Result := Format(RsMmUnknownError, [MciErrNo]); end; function MMCheck(const MciError: MCIERROR; const Msg: string): MCIERROR; begin if MciError <> MMSYSERR_NOERROR then raise EJclMciError.Create(MciError, Msg); Result := MciError; end; //=== CD Drive MCI Routines ================================================== function OpenCdMciDevice(var OpenParams: TMCI_Open_Parms; Drive: Char): MCIERROR; var OpenParam: DWORD; DriveName: array [0..2] of Char; begin FillChar(OpenParams, SizeOf(OpenParams), 0); OpenParam := MCI_OPEN_TYPE or MCI_OPEN_TYPE_ID or MCI_OPEN_SHAREABLE; OpenParams.lpstrDeviceType := PChar(MCI_DEVTYPE_CD_AUDIO); if Drive <> #0 then begin OpenParams.lpstrElementName := StrFmt(DriveName, '%s:', [UpCase(Drive)]); Inc(OpenParam, MCI_OPEN_ELEMENT); end; Result := mciSendCommand(0, MCI_OPEN, OpenParam, Cardinal(@OpenParams)); end; function CloseCdMciDevice(var OpenParams: TMCI_Open_Parms): MCIERROR; begin Result := mciSendCommand(OpenParams.wDeviceID, MCI_CLOSE, MCI_WAIT, 0); if Result = MMSYSERR_NOERROR then FillChar(OpenParams, SizeOf(OpenParams), 0); end; //=== CD Drive specific routines ============================================= procedure OpenCloseCdDrive(OpenMode: Boolean; Drive: Char); const OpenCmd: array [Boolean] of DWORD = (MCI_SET_DOOR_CLOSED, MCI_SET_DOOR_OPEN); var Mci: TMCI_Open_Parms; begin MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio)); try MMCheck(mciSendCommand(Mci.wDeviceID, MCI_SET, OpenCmd[OpenMode], 0)); finally CloseCdMciDevice(Mci); end; end; function IsMediaPresentInDrive(Drive: Char): Boolean; var Mci: TMCI_Open_Parms; StatusParams: TMCI_Status_Parms; begin MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio)); try FillChar(StatusParams, SizeOf(StatusParams), 0); StatusParams.dwItem := MCI_STATUS_MEDIA_PRESENT; MMCheck(mciSendCommand(Mci.wDeviceID, MCI_STATUS, MCI_STATUS_ITEM or MCI_WAIT, Cardinal(@StatusParams))); Result := Boolean(StatusParams.dwReturn); finally CloseCdMciDevice(Mci); end; end; function GetCdInfo(InfoType: TJclCdMediaInfo; Drive: Char): string; const InfoConsts: array [TJclCdMediaInfo] of DWORD = (MCI_INFO_PRODUCT, MCI_INFO_MEDIA_IDENTITY, MCI_INFO_MEDIA_UPC); var Mci: TMCI_Open_Parms; InfoParams: TMCI_Info_Parms; Buffer: array [0..255] of Char; begin Result := ''; MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio)); try InfoParams.dwCallback := 0; InfoParams.lpstrReturn := Buffer; InfoParams.dwRetSize := SizeOf(Buffer) - 1; if mciSendCommand(Mci.wDeviceID, MCI_INFO, InfoConsts[InfoType], Cardinal(@InfoParams)) = MMSYSERR_NOERROR then Result := Buffer; finally CloseCdMciDevice(Mci); end; end; function GetCDAudioTrackList(var TrackList: TJclCdTrackInfoArray; Drive: Char): TJclCdTrackInfo; var Mci: TMCI_Open_Parms; SetParams: TMCI_Set_Parms; TrackCnt, Ret: Cardinal; I: Integer; function GetTrackInfo(Command, Item, Track: DWORD): DWORD; var StatusParams: TMCI_Status_Parms; begin FillChar(StatusParams, SizeOf(StatusParams), 0); StatusParams.dwItem := Item; StatusParams.dwTrack := Track; if mciSendCommand(Mci.wDeviceID, MCI_STATUS, Command, Cardinal(@StatusParams)) = MMSYSERR_NOERROR then Result := StatusParams.dwReturn else Result := 0; end; begin MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio)); try FillChar(SetParams, SizeOf(SetParams), 0); SetParams.dwTimeFormat := MCI_FORMAT_MSF; MMCheck(mciSendCommand(Mci.wDeviceID, MCI_SET, MCI_SET_TIME_FORMAT, Cardinal(@SetParams))); Result.TrackType := ttOther; TrackCnt := GetTrackInfo(MCI_STATUS_ITEM, MCI_STATUS_NUMBER_OF_TRACKS, 0); SetLength(TrackList, TrackCnt); for I := 0 to TrackCnt - 1 do begin Ret := GetTrackInfo(MCI_STATUS_ITEM or MCI_TRACK, MCI_STATUS_LENGTH, I + 1); TrackList[I].Minute := mci_MSF_Minute(Ret); TrackList[I].Second := mci_MSF_Second(Ret); Ret := GetTrackInfo(MCI_STATUS_ITEM or MCI_TRACK, MCI_CDA_STATUS_TYPE_TRACK, I + 1); if Ret = MCI_CDA_TRACK_AUDIO then begin Result.TrackType := ttAudio; TrackList[I].TrackType := ttAudio; end else TrackList[I].TrackType := ttOther; end; Ret := GetTrackInfo(MCI_STATUS_ITEM, MCI_STATUS_LENGTH, 0); Result.Minute := mci_MSF_Minute(Ret); Result.Second := mci_MSF_Second(Ret); finally CloseCdMciDevice(Mci); end; end; function GetCDAudioTrackList(TrackList: TStrings; IncludeTrackType: Boolean; Drive: Char): string; var Tracks: TJclCdTrackInfoArray; TotalTime: TJclCdTrackInfo; I: Integer; S: string; begin TotalTime := GetCDAudioTrackList(Tracks, Drive); TrackList.BeginUpdate; try for I := Low(Tracks) to High(Tracks) do with Tracks[I] do begin if IncludeTrackType then begin case TrackType of ttAudio: S := RsMMTrackAudio; ttOther: S := RsMMTrackOther; end; S := Format('[%s]', [S]); end else S := ''; S := Format(RsMmCdTrackNo, [I + 1]) + ' ' + S; S := S + ' ' + Format(RsMMCdTimeFormat, [I + 1, Minute, Second]); TrackList.Add(S); end; finally TrackList.EndUpdate; end; Result := Format(RsMMCdTimeFormat, [TotalTime.Minute, TotalTime.Second]); end; // History: // $Log: JclMultimedia.pas,v $ // Revision 1.18 2005/12/12 21:54:10 outchy // HWND changed to THandle (linking problems with BCB). // // Revision 1.17 2005/03/08 08:33:22 marquardt // overhaul of exceptions and resourcestrings, minor style cleaning // // Revision 1.16 2005/02/25 07:20:16 marquardt // add section lines // // Revision 1.15 2005/02/24 16:34:52 marquardt // remove divider lines, add section lines (unfinished) // // Revision 1.14 2004/10/17 21:00:15 mthoma // cleaning // // Revision 1.13 2004/08/01 11:40:23 marquardt // move constructors/destructors // // Revision 1.12 2004/07/31 06:21:03 marquardt // fixing TStringLists, adding BeginUpdate/EndUpdate, finalization improved // // Revision 1.11 2004/07/28 18:00:53 marquardt // various style cleanings, some minor fixes // // Revision 1.10 2004/06/16 07:30:31 marquardt // added tilde to all IFNDEF ENDIFs, inherited qualified // // Revision 1.9 2004/06/14 11:05:53 marquardt // symbols added to all ENDIFs and some other minor style changes like removing IFOPT // // Revision 1.8 2004/05/05 07:33:49 rrossmair // header updated according to new policy: initial developers & contributors listed // // Revision 1.7 2004/04/08 16:59:17 mthoma // Fixed #1115. Changed $Data$ to $Date: 2005/12/12 21:54:10 $ // // Revision 1.6 2004/04/06 04:55:17 // adapt compiler conditions, add log entry // end.