Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

• Название: Советы по Delphi. Версия 1.4.3 от 1.1.2001
• Автор: Валентин Озеров
• Жанр: Программирование

…начиная с 1001. Смотрите другие файлы…

---

 if DirectSound.SetCooperativeLevel(Handle, DSSCL_NORMAL) <> DS_OK then Raise Exception.Create('Unable to set Cooperative Level');

end;

procedure TForm1.AppCreateWriteSecondary3DBuffer;

var

 BufferDesc  : DSBUFFERDESC;

 Caps        : DSBCaps;

 PCM         : TWaveFormatEx;

begin

 FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0);

 FillChar(PCM, SizeOf(TWaveFormatEx), 0);

 with BufferDesc do begin

  PCM.wFormatTag:=WAVE_FORMAT_PCM;

  if isStereo then PCM.nChannels:=2

  else PCM.nChannels:=1;

  PCM.nSamplesPerSec:=SamplesPerSec;

  PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;

  PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;

  PCM.wBitsPerSample:=Bits;

  PCM.cbSize:=0;

  dwSize:=SizeOf(DSBUFFERDESC);

  dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;

  dwBufferBytes:=Time*PCM.nAvgBytesPerSec;

  lpwfxFormat:=@PCM;

 end;

 if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then Raise Exception.Create('Create Sound Buffer failed');

end;

procedure TForm1.AppWriteDataToBuffer;

var

 AudioPtr1, AudioPtr2: Pointer;

 AudioBytes1, AudioBytes2: DWord;

 h: HResult;

 Temp: Pointer;

begin

 H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);

 if H = DSERR_BUFFERLOST  then begin

  Buffer.Restore;

  if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');

 end

 else if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');

 Temp:=@SoundData;

 Move(Temp^, AudioPtr1^, AudioBytes1);

 if AudioPtr2 <> nil then begin

  Temp:=@SoundData;

  Inc(Integer(Temp), AudioBytes1);

  Move(Temp^, AudioPtr2^, AudioBytes2);

 end;

 if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then Raise Exception.Create('Unable to UnLock Sound Buffer');

end;

procedure TForm1.CopyWAVToBuffer;

var

 Data     : PChar;

 FName    : TFileStream;

 DataSize : DWord;

 Chunk    : String[4];

 Pos      : Integer;

begin

 FName:=TFileStream.Create(Name,fmOpenRead);

 Pos:=24;

 SetLength(Chunk,4);

 repeat

  FName.Seek(Pos, soFromBeginning);

  FName.Read(Chunk[1], 4);

  Inc(Pos);

 until Chunk = 'data';

 FName.Seek(Pos+3, soFromBeginning);

 FName.Read(DataSize, SizeOf(DWord));

 GetMem(Data, DataSize);

 FName.Read(Data^, DataSize);

 FName.Free;

 AppWriteDataToBuffer(Buffer, 0, Data^, DataSize);

 FreeMem(Data, DataSize);

end;

var Pos : Single = -25;

procedure TForm1.AppSetSecondary3DBuffer;

begin

 if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then Raise Exception.Create('Failed to create IDirectSound3D object');

 if _3DBuffer.SetPosition(Pos, 1, 1, 0) <> DS_OK then Raise Exception.Create('Failed to set IDirectSound3D Position');

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

 CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);

 if SecondarySoundBuffer.Play(0, 0, DSBPLAY_LOOPING) <> DS_OK then ShowMessage('Can''t play the Sound');

 Timer1.Enabled:=True;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

begin

 SecondarySound3DBuffer.SetPosition(Pos,1,1,0);

 Pos:=Pos + 0.1;

end;

end.

Аппаратное обеспечение

CD-ROM

Открытие и закрытие нескольких приводов CD-ROM

Что касается вопроса "Открытие и закрытие привода CD-ROM", то при наличии более одного CD-ROMа в системе, рекомендую воспользоваться следующими функциями:

//                 ____       _          ______            __

//                / __ \_____(_)   _____/_  __/___ ____   / /____

//               / / / / ___/ / | / / _ \/ / / __ \/ __ \/ / ___/

//              / /_/ / /  / /| |/ /  __/ / / /_/ / /_/ / (__ )

//             /_____/_/  /_/ |___/\___/_/  \____/\____/_/____/

//

(*******************************************************************************

* DriveTools 1.0                                                               *

*                                                                              *

* (c) 1999 Jan Peter Stotz                                                     *

*                                                                              *

********************************************************************************

*                                                                              *

* If you find bugs, has ideas for missing featurs, feel free to contact me     *

* [email protected]                                                               *

*                                                                              *

********************************************************************************

* Date last modified: May 22, 1999                                             *

*******************************************************************************)

unit DriveTools;

interface

uses Windows, SysUtils, MMSystem;

function CloseCD(Drive: Char): Boolean;

function OpenCD(Drive: Char): Boolean;

implementation

function OpenCD(Drive : Char): Boolean;

Var

 Res: MciError;

 OpenParm: TMCI_Open_Parms;

 Flags: DWord;

 S: String;

 DeviceID: Word;

begin

 Result:=false;

 S:=Drive+':';

 Flags:=mci_Open_Type or mci_Open_Element;

 With OpenParm do begin

  dwCallback := 0;

  lpstrDeviceType := 'CDAudio';

  lpstrElementName := PChar(S);

 end;

 Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));

 IF Res<>0 Then exit;

 DeviceID:=OpenParm.wDeviceID;

 try

  Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);

  IF Res=0 Then exit;

  Result:=True;

 finally

  mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));

 end;

end;

function CloseCD(Drive : Char) : Boolean;

Var

 Res: MciError;

 OpenParm: TMCI_Open_Parms;

 Flags: DWord;

 S: String;

 DeviceID: Word;

begin

 Result:=false;

 S:=Drive+':';

 Flags:=mci_Open_Type or mci_Open_Element;

 With OpenParm do begin

  dwCallback := 0;lpstrDeviceType := 'CDAudio';

  lpstrElementName := PChar(S);

 end;

 Res:= mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));

 IF Res<>0 Then exit;

 DeviceID:=OpenParm.wDeviceID;

 try

  Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

  IF Res=0 Then exit;

  Result:=True;

 finally

  mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));

 end;

end;

end.

Прислал Vadim Petrov. 

Клавиатура

Переключение клавиатуры

Переключение языков из программы

Для переключения языка применяется вызов LoadKeyboardLayout:

var russian, latin: HKL;

russian:=LoadKeyboardLayout('00000419', 0);

latin:=LoadKeyboardLayout('00000409', 0); где то в программе

SetActiveKeyboardLayout(russian);

Прислал Igor Nikolaev aKa The Sprite. 

Как отловить нажатия клавиш в системе

Для этого используется функция GetAsyncKeyState(KeyCode)

в качестве параметра используются коды клавиш(например A – 65).

GetAsyncKeyState возвращает ненулевое значение если во время ее вызова нажата указаная клавиша.

//----Этот пример отлавливает нажатие клавиши «A»

//Этот код необходимо поместить в процедуру обработки

//таймера с интервалом «1»

if getasynckeystate(65)<>0 then showmessage('A – pressed');

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

Прислал Igor Nikolaev aKa The Sprite. 

Клавиша с кодом #0

Delphi 1 

В действительности она служит флагом проверки нажатия клавиши, по соглашению, код #0 означает, что никакой клавиши нажато не было. В некоторых случаях событие может активизировать передачу этого кода (например, прямым вызовом), или предок, возможно, уже обработал нажатие клавиши, и Key был установлен в #0.