C/C++ User's Journal & Wi…eveloper's Journal Tools/C-C__Users_Journal_and_Windows_Developers_Journal_Tools_1997.iso/diamond/pas/playstk.pas

Pascal/Delphi Source File | 1996-07-08 | 16.2 KB | 667 lines

{***************************************************************************
File:      playstk.pas
Version:   1.00
Tab stops: none
Project:   DiamondWare's Sound ToolKit for Windows
Copyright: 1996 DiamondWare, Ltd.  All rights reserved.*
Written:   by David Bollinger (based on playstk.c for WIN-STK)
Purpose:   Contains declarations for the DW Sound ToolKit for Windows
History:   96/02/24 DB Modified for 1.0
           96/03/27 JCL Finalized for 1.0
           96/04/14 JCL Finalized for 1.01
           96/05/13 JCL Finalized for 1.1 (no changes)
           96/05/27 JCL Finalized for 1.11
           96/07/08 JCL Finalized for 1.2 (no changes)

*Permission is expressly granted to use this program or any derivitive made
 from it to registered users of the WIN-STK.
***************************************************************************}



unit PlaySTK;


interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, StdCtrls, FileCtrl, Buttons;

type
  TForm1 = class(TForm)
    Logo: TImage;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    ListBox1: TListBox;
    NewBtn: TButton;
    PlayBtn: TButton;
    StopBtn: TButton;
    RemoveBtn: TButton;
    sbVolLeft: TScrollBar;
    sbVolRight: TScrollBar;
    sbPitch: TScrollBar;
    sbSwapLR: TCheckBox;
    RatePanel: TPanel;
    sbRate0: TRadioButton;
    sbRate1: TRadioButton;
    sbRate2: TRadioButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure DoNew(Sender: TObject);
    procedure DoPlay(Sender: TObject);
    procedure DoStop(Sender: TObject);
    procedure DoRemove(Sender: TObject);
    procedure sbVolLeftChange(Sender: TObject);
    procedure sbVolRightChange(Sender: TObject);
    procedure sbPitchChange(Sender: TObject);
    procedure sbSwapLRClick(Sender: TObject);
    procedure sbRate0Click(Sender: TObject);
    procedure sbRate1Click(Sender: TObject);
    procedure sbRate2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure DisplayErr(comment : PCHAR);
    function LoadFile(sndFile : string) : boolean;
    function ConvertWave(sndFile : string) : boolean;
  end;


var
  Form1: TForm1;



implementation

{$R *.DFM}
uses DWS;


const
   SOUNDTOTAL = 16;
   presentsnd : integer = 0;
   previoussnd : integer = 0;
   newselection : boolean = True;


var
   textselection : string;
   volleft, volright, pitch, swaplr, rate : WORD;
   wavesize : DWORD;
   wavetmp : array [0..SOUNDTOTAL-1] of PBYTE;
   hwavetmp : array [0..SOUNDTOTAL-1] of THandle;
   var dres : dws_DETECTRESULTS;
   var ideal : dws_IDEAL;
   var dplay1 : dws_DPLAYREC;
   var dplay2 : dws_DPLAYREC;



procedure TForm1.FormCreate(Sender: TObject);
var result : WORD;
begin
   volleft  := 8;
   volright := 8;
   pitch    := 8;
   swaplr   := 0;
   rate     := 1;

   if (dws_DetectHardWare(dres) = False) then
      DisplayErr('dws_DetectHardWare - During Create');

   if ((dres.digcaps and dws_digcap_11025_08_2) = 0) then
   begin
      Application.MessageBox('DiamondWare''s Sound ToolKit for Windows ' +
                             'supports sound playback on your computer. ' +
                             'However, this demo requires 8-bit stereo, ' +
                             'which your computer does not support. ' +
                             'Your sound hardware does not support ' +
                             '11025Hz, two channel, 8 bit sound. ' +
                             'This demo will not run properly on ' +
                             'your computer',
                             'Sound ToolKit Error',
                             MB_OK);
      Halt(1);
   end;

   if boolean(dres.muscaps and dws_muscap_MAPPER) then
      result := dws_muscap_MAPPER
   else if boolean(dres.muscaps and dws_muscap_FMSYNTH) then
      result := dws_muscap_FMSYNTH
   else if boolean(dres.muscaps and dws_muscap_SYNTH) then
      result := dws_muscap_SYNTH
   else if boolean(dres.muscaps and dws_muscap_SQSYNTH) then
      result := dws_muscap_SQSYNTH
   else if boolean(dres.muscaps and dws_muscap_MIDIPORT) then
      result := dws_muscap_MIDIPORT
   else
      result := dws_muscap_NONE;

   ideal.mustyp := result;                { 0=No Music, n=Music }
   ideal.digtyp := dws_digcap_11025_08_2; { everything rolled into one }
   ideal.dignvoices := 16;                { number of voices (up to 16) }

   if (dws_Init(dres, ideal) = False) then
      DisplayErr('dws_Init - During Create')
   else if (dws_XDig(128, 128) = False) then { half volume }
      DisplayErr('dws_XDig - During Create');

end;


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var i : integer;
begin

   dws_DClear;  { stop all playing sounds }
   dws_MClear;  { stop any playing music }
   dws_Kill;    { stop everything else }

   for i := 0 to SOUNDTOTAL-1 do
   begin
      if (hwavetmp[i] <> 0) then
      begin
         GlobalUnlock(hwavetmp[i]);
         GlobalFree(hwavetmp[i]);
      end;
   end;
end;


procedure TForm1.DisplayErr(comment : PCHAR);
var
  totstr : array[0..255] of char;
  errstr : PCHAR;
  status : WORD;
begin
  status := dws_ErrNo;
  case status of
    dws_EZERO:
    begin
      errstr := 'dws_EZERO (Why am I here?): %s';
    end;
    dws_NOTINITTED:
    begin
      errstr := 'dws_NOTINITTED: %s';
    end;
    dws_ALREADYINITTED:
    begin
      errstr := 'dws_ALREADYINITTED: %s';
    end;
    dws_NOTSUPPORTED:
    begin
      errstr := 'dws_NOTSUPPORTED: %s';
    end;
    dws_INTERNALERROR:
    begin
      errstr := 'dws_INTERNALERROR: %s';
    end;
    dws_INVALIDPOINTER:
    begin
      errstr := 'dws_INVALIDPOINTER: %s';
    end;
    dws_RESOURCEINUSE:
    begin
      errstr := 'dws_RESOURCEINUSE: %s';
    end;
    dws_MEMORYALLOCFAILED:
    begin
      errstr := 'dws_MEMORYALLOCFAILED: %s';
    end;
    dws_SETEVENTFAILED:
    begin
      errstr := 'dws_SETEVENTFAILED: %s';
    end;
    dws_BUSY:
    begin
      errstr := 'dws_BUSY: %s';
    end;
    dws_Init_BUFTOOSMALL:
    begin
      errstr := 'dws_Init_BUFTOOSMALL: %s';
    end;
    dws_D_NOTADWD:
    begin
      errstr := 'dws_D_NOTADWD: %s';
    end;
    dws_D_NOTSUPPORTEDVER:
    begin
      errstr := 'dws_D_NOTSUPPORTEDVER: %s';
    end;
    dws_D_BADDPLAY:
    begin
      errstr := 'dws_D_BADDPLAY: %s';
    end;
    dws_DPlay_NOSPACEFORSOUND:
    begin
      errstr := 'dws_DPlay_NOSPACEFORSOUND: %s';
    end;
    dws_WAV2DWD_NOTAWAVE:
    begin
      errstr := 'dws_WAV2DWD_NOTAWAVE: %s';
    end;
    dws_WAV2DWD_UNSUPPORTEDFORMAT:
    begin
      errstr := 'dws_WAV2DWD_UNSUPPORTEDFORMAT: %s';
    end;
    dws_M_BADMPLAY:
    begin
      errstr := 'dws_M_BADMPLAY: %s';
    end;
  else
    begin
      errstr := 'DEFAULT (unknown error!): %s';
    end;
  end;

  wvsprintf(totstr, errstr, comment);
  Application.MessageBox(totstr, 'Sound ToolKit Error', MB_ICONSTOP or MB_OK);

  Halt(1);
end;


function TForm1.LoadFile(sndfile : string) : boolean;
var
  txt : array [0..127] of char;
  stream : file;
begin
  sndfile := sndfile + char(0);
  if (hwavetmp[presentsnd] <> 0) then
  begin
    GlobalUnlock(hwavetmp[presentsnd]);
    GlobalFree(hwavetmp[presentsnd]);
  end;

  {$I-}
  AssignFile(stream, sndfile);
  if (IOResult = 0) then
  begin
    Reset(stream, 1);
    wavesize := FileSize(stream);
{$ifndef WIN32}
    if (wavesize > 65535) then
    begin
      Application.MessageBox('The selected file is too large for 16 bit ' +
                             'Delphi to read. Please try another, ' +
                             'smaller file.',
                             'Sound ToolKit Error',MB_OK);
      result := False;

      exit;
    end;
{$endif}
    hwavetmp[presentsnd] := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, wavesize);
    wavetmp[presentsnd] := PBYTE(GlobalLock(hwavetmp[presentsnd]));

    BlockRead(stream, wavetmp[presentsnd]^, wavesize);
    CloseFile(stream);
  end
  {$I+}
  else
  begin
    StrCopy(txt, 'Could not get size of ');
    StrCat(txt, @sndfile[1]);

    Application.MessageBox(txt, 'Sound ToolKit Error', MB_OK);

    result := False;

    exit;
  end;
  result := True;
end;


function TForm1.ConvertWave(sndFile : string) : boolean;
var
  txt : array [0..127] of char;
  wavedwd : PBYTE;
  status : WORDBOOL;
  len, tmp : DWORD;
  hwavedwd : THandle;
begin
  sndfile := sndfile + char(0);
  result := False;

  if (not LoadFile(sndfile)) then exit;

  tmp := wavesize;
  len := wavesize;

  status := dws_WAV2DWD(wavetmp[presentsnd], tmp, Nil);

  if (status = False) then
  begin
    StrCopy(txt, 'Could not get size of ');
    StrCat(txt, @sndfile[1]);

    Application.MessageBox(txt, 'Sound ToolKit Error', MB_OK);

    result := False;

    exit;
  end;

  hwavedwd := GlobalAlloc(GMEM_MOVEABLE, tmp);
  wavedwd := PBYTE(GlobalLock(hwavedwd));
  status := dws_WAV2DWD(waveTmp[presentsnd], len, wavedwd);

  if (status = False) then
  begin
    GlobalUnlock(hwavedwd);
    GlobalFree(hwavedwd);

    Application.MessageBox('Unable to convert WAV to internal format',
                           'Sound ToolKit Error',
                           MB_OK);
    result := False;

    exit;
  end;

  GlobalUnlock(hwavetmp[presentsnd]);
  GlobalFree(hwavetmp[presentsnd]);

  hwavetmp[presentsnd] := hwavedwd;
  wavetmp[presentsnd] := wavedwd;

  result := True;
end;


procedure TForm1.DoNew(Sender: TObject);
begin
  if OpenDialog1.Execute = True then
    ListBox1.Items.Add(OpenDialog1.Filename);
end;


procedure TForm1.DoPlay(Sender: TObject);
var
  buffer, extension : string;
  sel : integer;
  status : WORDBOOL;
  mplay : dws_MPLAYREC;
begin
  if (ListBox1.ItemIndex = -1) then
  begin
    Application.MessageBox('No listbox item is selected.',
                           'Sound ToolKit Error',
                           MB_OK);

    exit;
  end;

  presentsnd := ListBox1.ItemIndex;
  buffer := ListBox1.Items[presentsnd];

  if (buffer <> textselection) then
  begin
    newselection := True;
    textselection := buffer;
  end;

  { convert the retrieved text to lowercase }
  for sel := 1 to length(buffer) do
    if (buffer[sel] in ['A'..'Z']) then
      buffer[sel] := char(integer(buffer[sel]) + 32);

  extension := ExtractFileExt(buffer);

  if ((extension <> '.wav') and (extension <> '.dwd') and (extension <> '.mid')) then
  begin
    Application.MessageBox('File name format not known',
                           'Sound ToolKit Error',
                           MB_OK);

    exit;
  end;

  if ((extension = '.wav') or (extension = '.dwd')) then
  begin
    if (newselection) then
    begin
      if (extension = '.wav') then
      begin
        if (not ConvertWave(buffer)) then exit;
      end
      else if (extension = '.dwd') then
      begin
        if (not LoadFile(buffer)) then exit;
      end;

      dplay1.snd := wavetmp[presentsnd];
    end
    else
      dplay1.snd := wavetmp[previoussnd];

    dplay1.count := 1;

    if (volleft >= 8) then
      dplay1.lvol := WORD((volleft - 7) * 256)
    else
      dplay1.lvol := WORD(volleft * 32);

    if (volright >= 8) then
      dplay1.rvol := WORD((volright - 7) * 256)
    else
      dplay1.rvol := WORD(volright * 32);

    if (pitch >= 8) then
      dplay1.pitch := WORD((pitch - 7) * 256)
    else
      dplay1.pitch := WORD(pitch * 32);

    dplay1.flags := DWORD(dws_dplay_SND or dws_dplay_COUNT or dws_dplay_LVOL or dws_dplay_RVOL or dws_dplay_PITCH);

    status := dws_DPlay(dplay1);

    if (status = False) then
      DisplayErr('dws_DPlay - During DoNew');

    if (newselection) then
    begin
      previoussnd := presentsnd;
      inc(presentsnd);
      if (presentsnd >= SOUNDTOTAL) then
          presentsnd := 0;
    end;

    newselection := False;
  end

  else if (extension = '.mid') then
  begin
    buffer := buffer + char(0);
    mplay.track := Addr(buffer[1]);
    mplay.count := 1;

    status := dws_MPlay(mplay);
    if (status = False) then
      DisplayErr('dws_MPlay - During DoNew');

  end;
end;


procedure TForm1.DoStop(Sender: TObject);
begin

  dws_MClear;
  dws_DClear;

end;


procedure TForm1.DoRemove(Sender: TObject);
begin
  if (ListBox1.ItemIndex = -1) then
    Application.MessageBox('No listbox item is selected.', 'Sound ToolKit Error', mb_OK)
  else
    ListBox1.Items.Delete(ListBox1.ItemIndex);
end;


procedure TForm1.sbSwapLRClick(Sender: TObject);
var result : WORDBOOL;
begin
  swaplr := WORD(sbSwapLR.Checked);

  dws_DClear; { stop all playing sounds }
  dws_MClear; { stop any playing music }
  dws_Kill;   { stop everything else }

  if (swaplr <> 0) then
    ideal.flags := dws_ideal_SWAPLR
  else
    ideal.flags := 0;

  result := dws_Init(dres, ideal);

  if (result = False) then
    DisplayErr('dws_Init - During SwapLR');

end;


procedure TForm1.sbRate0Click(Sender: TObject);
var result : WORDBOOL;
begin
  rate := 0;

  dws_DClear; { stop all playing sounds }
  dws_MClear; { stop any playing music }
  dws_Kill;   { stop everything else }

  ideal.digtyp := dws_digcap_11025_08_2; { everything rolled into one }
  result := dws_Init(dres, ideal);

  if (result = False) then
    DisplayErr('dws_Init - During Rate 11025');

end;


procedure TForm1.sbRate1Click(Sender: TObject);
var result : WORDBOOL;
begin
  rate := 1;

  dws_DClear; { stop all playing sounds }
  dws_MClear; { stop any playing music }
  dws_Kill;   { stop everything else }

  ideal.digtyp := dws_digcap_22050_08_2; { everything rolled into one }
  result := dws_Init(dres, ideal);

  if (result = False) then
    DisplayErr('dws_Init - During Rate 22050');

end;


procedure TForm1.sbRate2Click(Sender: TObject);
var result : WORDBOOL;
begin
  rate := 2;

  dws_DClear; { stop all playing sounds }
  dws_MClear; { stop any playing music }
  dws_Kill;   { stop everything else }

  ideal.digtyp := dws_digcap_44100_08_2; { everything rolled into one }
  result := dws_Init(dres, ideal);

  if (result = False) then
    DisplayErr('dws_Init - During Rate 44100');

end;


procedure TForm1.sbVolLeftChange(Sender: TObject);
var result : WORDBOOL;
begin
  volleft := WORD(16 - sbVolLeft.Position);
  dplay1.flags := dws_dplay_SOUNDNUM or dws_dplay_LVOL;
  dplay2.flags := 0;

  result := dws_DGetInfo(dplay1, dplay2);

  if (result = False) then
    DisplayErr('dws_DGetInfo - During VolLeftChange');

  if (volleft >= 8) then
    dplay1.lvol := WORD((volleft - 7) * 256)
  else
    dplay1.lvol := WORD(volleft * 32);

  result := dws_DSetInfo(dplay1, dplay2);

  if (result = False) then
    DisplayErr('dws_DSetInfo - During VolLeftChange');

end;


procedure TForm1.sbVolRightChange(Sender: TObject);
var result : WORDBOOL;
begin
  volright := WORD(16 - sbVolRight.Position);
  dplay1.flags := dws_dplay_SOUNDNUM or dws_dplay_RVOL;
  dplay2.flags := 0;

  result := dws_DGetInfo(dplay1, dplay2);

  if (result = False) then
    DisplayErr('dws_DGetInfo - During VolRightChange');

  if (volright >= 8) then
    dplay1.rvol := WORD((volright - 7) * 256)
  else
    dplay1.rvol := WORD(volright * 32);

  result := dws_DSetInfo(dplay1, dplay2);

  if (result = False) then
    DisplayErr('dws_SGetInfo - During VolRightChange');

end;


procedure TForm1.sbPitchChange(Sender: TObject);
var result : WORDBOOL;
begin
  pitch := WORD(sbPitch.Position);
  dplay1.flags := dws_dplay_SOUNDNUM or dws_dplay_PITCH;
  dplay2.flags := 0;

  result := dws_DGetInfo(dplay1, dplay2);

  if (result = False) then
    DisplayErr('dws_DGetInfo - During PitchChange');

  if (pitch = 0) then inc(pitch);

  if (pitch >= 8) then
    dplay1.pitch := WORD((pitch - 7) * 256)
  else
    dplay1.pitch := WORD(pitch * 32);

  result := dws_DSetInfo(dplay1, dplay2);

  if (result = False) then
    DisplayErr('dws_DSetInfo - During PitchChange');

end;

end.