Модераторы: Snowy, Alexeis, MetalFan

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Генерирование звука определённых частот, с помощью звуковой карты 
:(
    Опции темы
Shuricksoft
Дата 4.10.2003, 22:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 177
Регистрация: 27.3.2002
Где: Odessa, Ukraine

Репутация: нет
Всего: нет
Как послать на звуковую карту сигнал определённой частоты? Особенно интересует передача двухтональных сигналов (МКТТ). На худой конец, сойдёт генерирование wav-файлов с нужным звуком.
Буду благодарен за люблую помощь.
PM MAIL ICQ   Вверх
stab
Дата 4.10.2003, 23:15 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
http://forum.vingrad.ru/index.php?act=ST&f...hl=%E7%E2%F3%EA

был аналогичный топик, могу выслать пример smile.gif

to Vit, может уже в FAQ засунуть? или там есть?

з.ы. тока до ума его довести надо, что-то там не совсем все клеиться...


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
Vit
Дата 4.10.2003, 23:45 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Vitaly Nevzorov
****


Профиль
Группа: Экс. модератор
Сообщений: 10964
Регистрация: 25.3.2002
Где: Chicago

Репутация: 1
Всего: 207
Вроде нет, доведи до ума - положу.


--------------------
With the best wishes, Vit
I have done so much with so little for so long that I am now qualified to do anything with nothing
Самый большой Delphi FAQ на русском языке здесь: www.drkb.ru
PM MAIL WWW ICQ   Вверх
Shuricksoft
Дата 5.10.2003, 20:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 177
Регистрация: 27.3.2002
Где: Odessa, Ukraine

Репутация: нет
Всего: нет
cully: Вот за пример буду очень благодарен =)
PM MAIL ICQ   Вверх
stab
Дата 5.10.2003, 22:34 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
Shuricksoft, давай ты его до ума доведешь и отдашь Vit'у, ок?

Там сейчас 2 проблемы:

1. Звук не очень чистый, что-то трещит, может быть из-за того, что глубина 8 бит.
2. Переодически происходят зависания.


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
Shuricksoft
Дата 6.10.2003, 11:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 177
Регистрация: 27.3.2002
Где: Odessa, Ukraine

Репутация: нет
Всего: нет
cully, ну, если смогу довести до ума, то отдам, конечно =) Но доводить пока нечего - ничего не пришло.
PM MAIL ICQ   Вверх
stab
Дата 7.10.2003, 15:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
выслал, сорри, что так долго заставил ждать -- времени совсем не было


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
Shuricksoft
Дата 7.10.2003, 18:24 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 177
Регистрация: 27.3.2002
Где: Odessa, Ukraine

Репутация: нет
Всего: нет
cully, благодарности я тебе мылом написал =) С кодом уже разобрался =) Автор опечатался. Стоит лишь в строке
Код

buf1, buf2: array[0..102] of Byte;

заменить 102 на 1024, как всё заработает =) Правда, странно: где-то в середине диапазона звук становится очень тихим. Неужели это такая избирательная восприимчивость человеческого уха?
А теперь вопрос: как сделать двухтональную посылку (ака МКТТ или CCITT)? :-/
PM MAIL ICQ   Вверх
Shuricksoft
Дата 7.10.2003, 18:31 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 177
Регистрация: 27.3.2002
Где: Odessa, Ukraine

Репутация: нет
Всего: нет
И ещё: кажись, там неточность с герцами... Как бы проверить?...
А если сдвинуть ограничения верхней и нежней частот, то вообще весело =) Ультразвук упорно не получается. А инфразвук получается (во всяком случае, его не слышно, как "ультразвук"), но с шумами.
PM MAIL ICQ   Вверх
Unregistered
Дата 8.10.2003, 22:06 (ссылка) | (голосов: 0) Загрузка ... Загрузка ... Быстрая цитата Цитата


Unregistered
Ну а здесь не судьба код привести?
  Вверх
stab
Дата 9.10.2003, 16:03 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
Цитата

Код
buf1, buf2: array[0..102] of Byte;



млин, бывает же, руки мне поотрывать за такой кодsmile.gif


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
stab
Дата 10.10.2003, 04:52 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
Цитата
Правда, странно: где-то в середине диапазона звук становится очень тихим. Неужели это такая избирательная восприимчивость человеческого уха?


там частота дискретизации стоит 22050 Hz, это мало для нормального воспроизведения частот более чем 11025 Hz (теорема Котельникова)

Цитата
кажись, там неточность с герцами


хз, при 1000 Гц, звук очень знакомый, такой по телику ночью гоняют smile.gif

Цитата
заменить 102 на 1024, как всё заработает


Треск пропал, но все так же виснет, если нажать Play, Stop, Play.


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
stab
Дата 10.10.2003, 04:56 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
додумался, надо убрать:

Код

 if ho <> 0 then begin
   DoIt := False;
   OutCallback(ho, WOM_DONE, 0, 0, 0);
 end;


из PlayButClick


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
maxim1000
Дата 10.10.2003, 11:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Участник
Сообщений: 3334
Регистрация: 11.1.2003
Где: Киев

Репутация: 1
Всего: 110
так уж получилось, что эта тема оказалась интересной и для меня (вообще-то, мне нужно записывать звук, но, думаю, вывод сигнала может помочь в этом)
не могли бы вы выслать на почту то, что есть на данный момент (т.к. у меня есть некоторые ограничения по времени)
заранее благодарен...

Это сообщение отредактировал(а) maxim1000 - 10.10.2003, 11:52


--------------------
qqq
PM WWW   Вверх
stab
Дата 10.10.2003, 19:08 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Экс. модератор
Сообщений: 1839
Регистрация: 1.1.2003

Репутация: нет
Всего: 48
Код

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 mmsystem, StdCtrls, ComCtrls;

type
 TForm1 = class(TForm)
   DevList: TListBox;
   StaticText1: TStaticText;
   StaticText2: TStaticText;
   OutList: TListBox;
   StaticText3: TStaticText;
   InList: TListBox;
   PlayBut: TButton;
   StaticText4: TStaticText;
   MixList: TListBox;
   FreqTrack: TTrackBar;
   FreqText: TStaticText;
   StopBut: TButton;
   procedure FormCreate(Sender: TObject);
   procedure PlayButClick(Sender: TObject);
   procedure FreqTrackChange(Sender: TObject);
   procedure StopButClick(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
 private
   { Private declarations }
   procedure FillBySin(var Buffer: array of Byte; const Freq, Amp: Integer; const Time: Cardinal);
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

var
   buf1, buf2: array[0..1024] of Byte;
   hdr1, hdr2: WAVEHDR;
   DoIt: Boolean;
   ho: HWAVEOUT = 0;
   tm: Cardinal;    

procedure TForm1.FormCreate(Sender: TObject);
var
 acaps: AUXCAPS;
 wocaps: WAVEOUTCAPS;
 wicaps: WAVEINCAPS;
 mcaps: MIXERCAPS;
 dev: Integer;
begin
 for dev := 0 to auxGetNumDevs() - 1 do begin
   auxGetDevCaps(dev, @acaps, SizeOf(AUXCAPS));
   with acaps do begin
     DevList.Items.Add(szPname);
   end;
 end;
 for dev := 0 to waveOutGetNumDevs() - 1 do begin
   waveOutGetDevCaps(dev, @wocaps, SizeOf(WAVEOUTCAPS));
   with wocaps do begin
     OutList.Items.Add(szPname);
   end;
 end;
 for dev := 0 to waveInGetNumDevs() - 1 do begin
   waveInGetDevCaps(dev, @wicaps, SizeOf(WAVEINCAPS));
   with wicaps do begin
     InList.Items.Add(szPname);
   end;
 end;
 for dev := 0 to mixerGetNumDevs() - 1 do begin
   mixerGetDevCaps(dev, @mcaps, SizeOf(MIXERCAPS));
   with mcaps do begin
     MixList.Items.Add(szPname);
   end;
 end;

 OutList.ItemIndex := 0;
 InList.ItemIndex := 0;

 FreqText.Caption := IntToStr(FreqTrack.Position);
end;

function OutCallback(hwo, msg, inst, p1, p2: Integer): Integer; stdcall;
begin
 if msg = WOM_DONE then begin
   if DoIt then
     if p1 = Integer(@hdr1) then begin
       waveOutUnprepareHeader(hwo, @hdr1, SizeOf(WAVEHDR));
       Inc(tm, Length(buf2));
       Form1.FillBySin(buf1, Form1.FreqTrack.Position, 100, tm);
       waveOutPrepareHeader(hwo, @hdr1, SizeOf(WAVEHDR));
       waveOutWrite(hwo, @hdr1, SizeOf(WAVEHDR));
     end
     else begin
       waveOutUnprepareHeader(hwo, @hdr2, SizeOf(WAVEHDR));
       Inc(tm, Length(buf1));
       Form1.FillBySin(buf2, Form1.FreqTrack.Position, 100, tm);
       waveOutPrepareHeader(hwo, @hdr2, SizeOf(WAVEHDR));
       waveOutWrite(hwo, @hdr2, SizeOf(WAVEHDR));
     end
   else begin
     waveOutUnprepareHeader(hwo, @hdr1, SizeOf(WAVEHDR));
     waveOutUnprepareHeader(hwo, @hdr2, SizeOf(WAVEHDR));
     waveOutReset(hwo);
     waveOutClose(hwo);
     ho := 0;
   end;
 end;
 Result := 0;
end;

procedure TForm1.PlayButClick(Sender: TObject);
var
 fmt: tWAVEFORMATEX;
begin

{  if ho <> 0 then begin
   DoIt := False;
   OutCallback(ho, WOM_DONE, 0, 0, 0);
 end;}
 DoIt := True;
 with fmt do begin
   wFormatTag := WAVE_FORMAT_PCM;
   nChannels := 1;
   nSamplesPerSec := 22050;
   nAvgBytesPerSec := 22050;
   nBlockAlign := 1;
   wBitsPerSample := 8;
 end;

 if waveOutOpen(@ho, OutList.ItemIndex, @fmt, Cardinal(@OutCallback), 5, CALLBACK_FUNCTION {or WAVE_ALLOWSYNC}) = MMSYSERR_NOERROR then begin
   tm := 0;
   FillBySin(buf1, FreqTrack.Position, 100, tm);
   with hdr1 do begin
     lpData := @buf1;
     dwBufferLength := Length(buf1);
     dwFlags := 0;
   end;
   waveOutPrepareHeader(ho, @hdr1, SizeOf(WAVEHDR));
   waveOutWrite(ho, @hdr1, SizeOf(WAVEHDR));

   Inc(tm, Length(buf1));
   FillBySin(buf1, FreqTrack.Position, 100, tm);
   with hdr2 do begin
     lpData := @buf2;
     dwBufferLength := Length(buf2);
     dwFlags := 0;
   end;
   waveOutPrepareHeader(ho, @hdr2, SizeOf(WAVEHDR));
   waveOutWrite(ho, @hdr2, SizeOf(WAVEHDR));
 end
 else
   Beep;
end;

procedure TForm1.FreqTrackChange(Sender: TObject);
begin
 FreqText.Caption := IntToStr(FreqTrack.Position);
end;

procedure TForm1.FillBySin(var Buffer: array of Byte; const Freq,
 Amp: Integer; const Time: Cardinal);
var
 i: Cardinal;
 k: Single;
begin

 k := (freq * 2 * pi) / 22050;

 for i := 0 to  Cardinal(Length(Buffer)) - 1 do
   Buffer[i] := Round(Amp * Sin((Time + i) * k)) + 128;

end;

procedure TForm1.StopButClick(Sender: TObject);
begin
 DoIt := False;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 DoIt := False;
end;

end.


object Form1: TForm1
 Left = 298
 Top = 304
 BorderStyle = bsDialog
 Caption = 'WAVE'
 ClientHeight = 318
 ClientWidth = 489
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 OldCreateOrder = False
 OnCreate = FormCreate
 OnDestroy = FormDestroy
 PixelsPerInch = 96
 TextHeight = 13
 object DevList: TListBox
   Left = 8
   Top = 32
   Width = 153
   Height = 100
   ItemHeight = 13
   TabOrder = 0
 end
 object StaticText1: TStaticText
   Left = 16
   Top = 8
   Width = 64
   Height = 17
   Caption = 'aux devices:'
   TabOrder = 1
 end
 object StaticText2: TStaticText
   Left = 176
   Top = 8
   Width = 91
   Height = 17
   Caption = 'wave out devices:'
   TabOrder = 2
 end
 object OutList: TListBox
   Left = 168
   Top = 32
   Width = 153
   Height = 100
   ItemHeight = 13
   TabOrder = 3
 end
 object StaticText3: TStaticText
   Left = 336
   Top = 8
   Width = 84
   Height = 17
   Caption = 'wave in devices:'
   TabOrder = 4
 end
 object InList: TListBox
   Left = 328
   Top = 32
   Width = 153
   Height = 100
   ItemHeight = 13
   TabOrder = 5
 end
 object PlayBut: TButton
   Left = 207
   Top = 144
   Width = 75
   Height = 25
   Caption = 'Play'
   TabOrder = 6
   OnClick = PlayButClick
 end
 object StaticText4: TStaticText
   Left = 16
   Top = 144
   Width = 36
   Height = 17
   Caption = 'mixers:'
   TabOrder = 7
 end
 object MixList: TListBox
   Left = 8
   Top = 168
   Width = 153
   Height = 100
   ItemHeight = 13
   TabOrder = 8
 end
 object FreqTrack: TTrackBar
   Left = 1
   Top = 280
   Width = 400
   Height = 25
   Max = 20000
   Min = 20
   Orientation = trHorizontal
   Frequency = 1
   Position = 1000
   SelEnd = 0
   SelStart = 0
   TabOrder = 9
   TickMarks = tmBottomRight
   TickStyle = tsNone
   OnChange = FreqTrackChange
 end
 object FreqText: TStaticText
   Left = 416
   Top = 284
   Width = 4
   Height = 4
   TabOrder = 10
 end
 object StopBut: TButton
   Left = 207
   Top = 176
   Width = 75
   Height = 25
   Caption = 'Stop'
   TabOrder = 11
   OnClick = StopButClick
 end
end


вот, все что на данный момент есть, думаю для топика в FAQ этого достаточно


--------------------
6, 6, 6 - the number of the beast.
PM MAIL WWW   Вверх
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Звук, графика и видео"
Girder
Snowy
Alexeis

Запрещено:

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делится вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи
  • По вопросам разработки игр стоит заглянуть сюда

FAQ раздела лежит здесь!

Если Вам помогли и атмосфера форума Вам понравилась, то заходите к нам чаще! С уважением, Girder, Snowy.
 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Звук, графика и видео | Следующая тема »

Подписаться на тему | Подписка на этот форум | Скачать/Распечатать тему


 




[ Время генерации скрипта: 0.0547 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
 По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.