Как программно изменять громкость звука

unit
 Volumes;
 
interface
 
 
uses
 
  Windows, Messages, Classes, ExtCtrls, ComCtrls, MMSystem; 

const
 
  CDVolume       = 0; 
  WaveVolume     = 1; 
  MidiVolume     = 2; 
 
type
 
  TVolumeControl = class
(TComponent) 
  private

    FDevices     : array
[0..2] of
 Integer; 
    FTrackBars   : array
[0..2] of
 TTrackBar; 
    FTimer       : TTimer; 
    function
       GetInterval: Integer; 
    procedure
      SetInterval(AInterval: Integer);
    function
       GetVolume(AIndex: Integer): Byte; 
    procedure
      SetVolume(AIndex: Integer; aVolume: Byte); 
    procedure
      InitVolume; 
    procedure
      SetTrackBar(AIndex: Integer; ATrackBar: TTrackBar); 
    { Private declarations } 
    procedure
      Update(Sender: TObject); 
    procedure
      Changed(Sender: TObject); 
  protected
 
    { Protected declarations } 
    procedure
      Notification(AComponent: TComponent; AOperation: 
TOperation); override
; 
  public
 
    { Public declarations } 
    constructor
    Create(AOwner: TComponent); override
; 
    destructor
     Destroy; override
; 
  published
 
    { Published declarations } 
    property
       Interval: Integer read
 GetInterval write
 SetInterval default
 
500; 
    property
       CDVolume: Byte index 0 read
 GetVolume write
 SetVolume stored
 
False; 
    property
       CDTrackBar: TTrackBar index 0 read
 FTrackBars[0] write
 
SetTrackBar; 
    property
       WaveVolume: Byte index 1 read
 GetVolume write
 SetVolume 
stored
 False; 
    property
       WaveTrackBar: TTrackBar index 1 read
 FTrackBars[1] write
 
SetTrackBar; 
    property
       MidiVolume: Byte index 2 read
 GetVolume write
 SetVolume
stored
 False; 
    property
       MidiTrackBar: TTrackBar index 2 read
 FTrackBars[2] write
 
SetTrackBar; 
  end
; 
 
procedure
 Register
; 
 
implementation
 
 
procedure
 Register
; 
begin
 
  RegisterComponents('Any', [TVolumeControl]); 
end
; 
 
type
 
    TVolumeRec = record
 
    case
 Integer of
 
    0: (LongVolume: Longint); 
    1: (LeftVolume, 
        RightVolume : Word); 
    end
; 
 
    function
       TVolumeControl.GetInterval: Integer; 
    begin
 
      Result := FTimer.Interval; 
    end
; 
 
    procedure
      TVolumeControl.SetInterval(AInterval: Integer);
    begin
 
      FTimer.Interval := AInterval; 
    end
; 
 
    function
       TVolumeControl.GetVolume(AIndex: Integer): Byte; 
    var
 Vol: TVolumeRec; 
    begin
 
      Vol.LongVolume := 0; 
      if
 FDevices[AIndex] < >  -1 then
 
      case
 AIndex of
 
      0: auxGetVolume(FDevices[AIndex], @Vol.LongVolume); 
      1: waveOutGetVolume(FDevices[AIndex], @Vol.LongVolume); 
      2: midiOutGetVolume(FDevices[AIndex], @Vol.LongVolume); 
      end
; 
      Result := (Vol.LeftVolume + Vol.RightVolume) shr
 9; 
    end
; 
 
    procedure
      TVolumeControl.SetVolume(aIndex: Integer; aVolume: Byte); 
    var
 Vol: TVolumeRec; 
    begin
 
      if
 FDevices[AIndex] < >  -1 then
 
      begin
 
        Vol.LeftVolume := aVolume shl
 8; 
        Vol.RightVolume := Vol.LeftVolume; 
        case
 AIndex of
 
        0: auxSetVolume(FDevices[AIndex], Vol.LongVolume); 
        1: waveOutSetVolume(FDevices[AIndex], Vol.LongVolume); 
        2: midiOutSetVolume(FDevices[AIndex], Vol.LongVolume);
        end
; 
      end
; 
    end
; 
 
    procedure
      TVolumeControl.SetTrackBar(AIndex: Integer; ATrackBar: 
TTrackBar); 
    begin
 
      if
 ATrackBar < >  FTrackBars[AIndex] then
 
      begin
 
        FTrackBars[AIndex] := ATrackBar; 
        Update(Self); 
      end
; 
    end
; 
 
 AOperation: TOperation); 
    var
 I: Integer; 
    begin
 
      inherited
 Notification(AComponent, AOperation); 
      if
 (AOperation = opRemove) then
 
      for
 I := 0 to
 2 do
 if
 (AComponent = FTrackBars[I]) 
      then
 FTrackBars[I] := Nil
; 
    end
; 
 
    procedure
      TVolumeControl.Update(Sender: TObject); 
    var
 I: Integer; 
    begin
 
      for
 I := 0 to
 2 do
 
      if
 Assigned(FTrackBars[I]) then

      with
 FTrackBars[I] do
 
      begin
 
        Min := 0; 
        Max := 255; 
        if
 Orientation = trVertical 
        then
 Position := 255 - GetVolume(I) 
        else
 Position := GetVolume(I); 
        OnChange := Self.Changed; 
      end
; 
    end
; 
 
    constructor
    TVolumeControl.Create(AOwner: TComponent); 
    begin
 
      inherited
 Create(AOwner); 
      FTimer := TTimer.Create(Self); 
      FTimer.OnTimer := Update; 
      FTimer.Interval := 500; 
      InitVolume; 
    end
; 
 
    destructor
     TVolumeControl.Destroy; 
    var
 I: Integer; 
    begin
 
      FTimer.Free; 
      for
 I := 0 to
 2 do
 
      if
 Assigned(FTrackBars[I]) then
 
      FTrackBars[I].OnChange := Nil
; 
      inherited
 Destroy;
    end
; 
 
    procedure
      TVolumeControl.Changed(Sender: TObject); 
    var
 I: Integer; 
    begin
 
      for
 I := 0 to
 2 do
 
      if
 Sender = FTrackBars[I] then
 
      with
 FTrackBars[I] do
 
      begin
 
        if
 Orientation = trVertical 
        then
 SetVolume(I, 255 - Position) 
        else
 SetVolume(I, Position); 
      end
; 
    end
; 
 
    procedure
      TVolumeControl.InitVolume; 
    var
 AuxCaps     : TAuxCaps; 
        WaveOutCaps : TWaveOutCaps; 
        MidiOutCaps : TMidiOutCaps; 
        I,J         : Integer; 
    begin
 
      FDevices[0] := -1; 
      for
 I := 0 to
 auxGetNumDevs - 1 do
 
      begin
 
        auxGetDevCaps(I, @AuxCaps, SizeOf(AuxCaps)); 
        if
 (AuxCaps.dwSupport and
 AUXCAPS_VOLUME) < >  0 then
 
        begin
 
          FTimer.Enabled := True
;
          FDevices[0] := I; 
          break; 
        end
; 
      end
; 
      FDevices[1] := -1; 
      for
 I := 0 to
 waveOutGetNumDevs - 1 do
 
      begin
 
        waveOutGetDevCaps(I, @WaveOutCaps, SizeOf(WaveOutCaps)); 
        if
 (WaveOutCaps.dwSupport and
 WAVECAPS_VOLUME) < >  0 then
 
        begin
 
          FTimer.Enabled := True
; 
          FDevices[1] := I; 
          break; 
        end
; 
      end
; 
      FDevices[2] := -1; 
      for
 I := 0 to
 midiOutGetNumDevs - 1 do
 
      begin
 
        MidiOutGetDevCaps(I, @MidiOutCaps, SizeOf(MidiOutCaps)); 
        if
 (MidiOutCaps.dwSupport and
 MIDICAPS_VOLUME) < >  0 then
 
        begin
 
          FTimer.Enabled := True
; 
          FDevices[2] := I; 
          break; 
        end
; 
      end
;
    end
;

end
.

Другое по теме:

• Как воспроизвести wav-файл из ресурса (в EXE)
• Работа с микрофоном
• Изменение громкости