DBR Delphi-Ecke

// Bekannterweise kann man wav-Dateien so abspielen:
// playsound('c:\drums.wav', 0, SND_FILENAME or SND_ASYNC);
// oder aus Gründen der Abwärtskompatibilität:
// sndPlaySound('c:\drums.wav', SND_ASYNC);
// Hier noch drei Varianten über mciSendString, mciSendCommand, WaveOut:

// Getestet mit D4 unter WinME

// Variante 1: MCISendString

uses mmsystem; 
 
var 
  art: string; 
 
procedure SoundPause; 
begin 
  MCISendString(pchar('stop MySound'), nil, 0, 0); 
end; 
 
procedure SoundAus; 
begin 
  soundpause; 
  MCISendString(pchar('close MySound'), nil, 0, 0); 
end; 
 
function SoundGo: boolean; 
begin 
  result := MCISendString(pchar('play MySound'), nil, 0, 0) = 0; 
end; 
 
function SoundPlay(datei: string): boolean; 
begin 
  soundaus; 
  MCISendString(pchar('open ' + datei + ' type ' + art + ' alias MySound'), 
    nil, 0, 0); 
  result := soundgo; 
end; 
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); 
begin 
  soundaus; 
end; 
 
 
// --- Beispielaufrufe --- 
 
 
// Sound-Datei abspielen 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  art := 'waveaudio'; 
  if not soundplay('c:\sony.wav') then showmessage('Fehler'); 
end; 
 
 
// Sound-Datei beenden 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  soundaus; 
end; 
 
 
// Sound-Datei pausieren lassen 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  soundpause; 
end; 
 
 
// Sound-Datei nach Pause weiterlaufen lassen 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  soundgo; 
end; 
 
 
// Status abfragen 
 
procedure TForm1.Button5Click(Sender: TObject); 
var buf: array[0..29] of char; 
begin 
  if mciSendString('status MySound mode', buf, 30, 0) = 0 
    then begin 
    if buf = 'stopped' then 
      showmessage('Der von diesem Programm gestartete Sound pausiert') 
    else showmessage('Ein von diesem Programm gestartete Sound läuft gerade'); 
  end else 
    showmessage('Dieses Programm spielt zur Zeit keinen Sound'); 
end; 
 
// ----------------------------------------------------------------- 
 

// Je nach Betriebssystem bzw. Versionsstand kann
// man auch Midis abspielen:

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  art := 'sequencer'; 
  if not soundplay('d:\techno.mid') then showmessage('Fehler'); 
end;

// -----------------------------------------------------------------

// Variante 2: mciSendCommand

// Die Nummerierung der Sounds geschieht nach Gleichzeitigkeit, soll heißen,
// wenn man den zweiten Sound startet während der erste noch läuft, erhält
// er die Nummer "2". Startet der Sound nachdem der erste schon beendet ist,
// bekommt er die Nummer "1".

unit Unitx; 
 
interface 
 
uses 
  Windows, Forms, Classes, Sysutils, Controls, StdCtrls, Messages, Dialogs, 
  mmsystem; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Button4: TButton; 
    Label1: TLabel; 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure Button4Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure MMNotify(var M: TMessage); message MM_MCINOTIFY; 
    function SndPlay(const Datei: string):  Cardinal; 
    procedure SndStop(ID: PUint); 
  end; 
 
var 
  Form1: TForm1;
 
implementation 
 
{$R *.DFM} 
 
var 
  IDS: array[0..2] of integer = (0, 0, 0); // z.B. 3 Sounds gleichzeitig 
 
function TForm1.SndPlay(const Datei: string): Cardinal; 
var 
  op: TMCI_Open_Parms; 
begin 
  zeromemory(@op, sizeof(op)); 
  op.dwCallback := handle; 
  op.lpstrElementName := PChar(Datei); 
  mciSendCommand(0, MCI_OPEN, MCI_OPEN_ELEMENT, integer(@op)); 
  result := op.wDeviceID; 
  mciSendCommand(result, MCI_PLAY, MCI_NOTIFY, integer(@op)); 
end; 
 
procedure TForm1.MMNotify(var M: TMessage); 
var 
  s: string; 
  procedure setnull; 
  var 
    x: integer; 
  begin 
    for x := 0 to high(IDS) do 
      if IDS[x] = M.LParam then begin 
        IDS[x] := 0; 
        break; 
      end; 
  end; 
begin 
  mciSendCommand(M.LParam, MCI_CLOSE, 0, 0); 
  s := #32 + inttostr(M.LParam) + #32; 
  case M.WParam of 
    MCI_NOTIFY_SUCCESSFUL: begin 
        showmessage('Sound' + s + 'Beendet'); 
        setnull; 
      end; 
    MCI_NOTIFY_ABORTED: begin 
        showmessage('Sound' + s + 'Gestoppt'); 
        setnull; 
      end; 
    MCI_NOTIFY_FAILURE: begin 
        showmessage('Fehler bei Sound' + s + 'aufgetreten'); 
        setnull 
      end; 
  end; 
end; 
 
procedure TForm1.SndStop(ID: PUint); 
begin 
  if ID^ <> 0 then begin 
    mciSendCommand(ID^, MCI_CLOSE, 0, 0); 
    ID^ := 0; 
  end; 
end; 
 
 
// -- Beispielaufrufe -- 
 
// ersten Sound starten 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  c: Cardinal; 
begin 
  c := SndPlay('c:\katz.wav'); 
  if IDS[0] = 0 then IDS[0] := c; 
end; 
 
// zuerst gestarteten Sound abbrechen 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  SndStop(@IDS[0]); 
end; 
 
// zweiten Sound starten 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  c: Cardinal; 
begin 
  c := SndPlay('c:\hund.wav'); 
  if IDS[1] = 0 then IDS[1] := c; 
end; 
 
// als zweites gestarteten Sound abbrechen 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  SndStop(@IDS[1]); 
end; 
 
end.

// -----------------------------------------------------------------

// Variante 3: WaveOut-Befehle

// Mit dem Code können unkomprimierte Microsoft-Wave-Dateien abgespielt
// werden (sogenannte PCM-Dateien). Andere Wave-Formate werden abgelehnt.

uses mmsystem; 
 
var 
  wavehandle: PHWAVEOUT = nil; 
  pause: boolean = false; 
  inuse: boolean = false; 
 
function PlayMicrosoftWaveform(Datei: TFilename): boolean; 
var 
  lpFormat: PWaveFormatEx; 
  lpwheader: pWaveHdr; 
  p: PChar; 
  ms: TMemorystream; 
  function gelesen: boolean; 
  begin 
    with lpFormat^ do begin 
      move(p^, wFormatTag, 2); 
      if wFormatTag = WAVE_FORMAT_PCM then begin 
        Result := true; 
        inc(p, 2); 
        move(p^, nChannels, 14); 
      end else Result := false; 
    end; 
  end; 
begin 
  Result := false; 
  if inuse then exit; 
  inuse := true; 
  if FileExists(Datei) then begin 
    ms := TMemorystream.create; 
    ms.loadfromfile(Datei); 
    p := ms.memory; 
    if copy(p, 1, 4) = 'RIFF' then begin 
      inc(p, 8); 
      if copy(p, 1, 4) = 'WAVE' then begin 
        new(lpFormat); 
        inc(p, 12); 
        if gelesen then begin 
          new(lpwheader); 
          new(wavehandle); 
          with lpwheader^ do begin 
            lpData := ms.memory; 
            dwBufferLength := ms.size; 
          end; 
          if waveOutOpen(wavehandle, WAVE_MAPPER, lpFormat, 0, 0, CALLBACK_NULL) 
            = MMSYSERR_NOERROR then begin 
            if waveOutPrepareHeader(wavehandle^, lpwheader, sizeof(lpwheader^)) 
              = MMSYSERR_NOERROR then begin 
              if waveOutWrite(wavehandle^, lpwheader, sizeof(lpwheader^)) 
                = MMSYSERR_NOERROR then begin 
                Result := true; 
                repeat 
                  application.processmessages; 
                until (lpwheader^.dwFlags and WHDR_DONE = WHDR_DONE) 
                  or Application.terminated; 
                waveOutUnPrepareHeader(wavehandle^, lpwheader, 
                  sizeof(lpwheader^)); 
                waveOutClose(wavehandle^); 
              end; 
            end; 
          end; 
          dispose(wavehandle); 
          dispose(lpwheader); 
        end; 
        dispose(lpFormat); 
      end; 
    end; 
    ms.free; 
  end; 
  inuse := false; 
  pause := false; 
end; 
 
 
// Abspielen 
 
procedure TForm1.Button6Click(Sender: TObject); 
begin 
  if not PlayMicrosoftWaveform('C:\WINDOWS\Media\Windows XP-Startvorgang.wav') 
    then showmessage('Fehler'); 
end; 
 
 
// Pause <--> fortsetzen 
 
procedure TForm1.Button8Click(Sender: TObject); 
begin 
  if not inuse or (wavehandle = nil) then exit; 
  if pause then begin 
    waveOutRestart(wavehandle^); 
    pause := false; 
  end else begin 
    waveOutPause(wavehandle^); 
    pause := true; 
  end; 
end; 
 
 
// Stop 
 
procedure TForm1.Button9Click(Sender: TObject); 
begin 
  if not inuse or (wavehandle = nil) then exit; 
  waveOutReset(wavehandle^); 
end;