VPF::О записе звука с микрофона - Форум программистов

Ak47black

Дата 14.9.2007, 22:28 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 2205
Регистрация: 2.12.2005

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

Здравствуйте.
Меня интересует как можно записать звук с микрофона даже если стоит галочка Mute на микрофоне где регулируется уровень звука?
Вижу что в Skype так можно сделать, а как это программно сделать можно?

Ak47black

Дата 15.9.2007, 20:21 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 2205
Регистрация: 2.12.2005

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

Pardon, при низкоуровневых процедурах итак идет захват даже при выключенном микрофоне.

RinOSpro

Дата 17.9.2007, 08:02 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Ak47black ну раз нашел решение поделись и с другими. Может кого то это тоже интересует

Alexeis

Дата 17.9.2007, 09:00 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

RinOSpro, понимаешь, просто функции WaveIn**** используют свой регулятор громкости для каждого дескриптора, вот потому их и не интересует состояние общесистемного. Тут решение и нет как такового, просто вопрос был по принципу работы.

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

RinOSpro

Дата 17.9.2007, 12:23 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

В DRKB я нашел пример снятия звука с микрофона, и отображение звуковых данных в виде

графика, но не пойму из как сохранить это в wav файл!

Код



Unit Unit1;

interface
uses

Windows, Messages, SysUtils, Classes, Graphics, Forms,
Dialogs, MMSystem;
 
type

TWavArrayBuf = array[0..1023]of byte;
PWavArrayBuf = ^TWavArrayBuf;

TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
   WaveFormat: TWaveFormatEx;
   WaveIn: PHWaveIn;
   procedure WndProc(var Msg: TMessage); override;
   function InitWaveIn: Boolean;
   procedure CloseWaveIn;
end;

var

Form1: TForm1;
 
implementation

uses Math;

{$R *.dfm}

function TForm1.InitWaveIn: Boolean;
var
I, Err: Integer;
WaveHdr: PWaveHdr;
WavBuff: PWavArrayBuf;
 
procedure FreeData;
begin
   if WavBuff <> nil then Dispose(WavBuff);
   if WaveHdr <> nil then Dispose(WaveHdr);
   if WaveIn <> nil then Dispose(WaveIn);
end;

begin
Result := False;
WaveFormat.wFormatTag := WAVE_FORMAT_PCM;
WaveFormat.nChannels := 1; 
WaveFormat.nSamplesPerSec := 44100;
WaveFormat.nAvgBytesPerSec := 44100;
WaveFormat.nBlockAlign := 4;
WaveFormat.wBitsPerSample := 8;
WaveIn := New(PHWaveIn);
Err := WaveInOpen(WaveIn, 0, @WaveFormat, Handle, 0, CALLBACK_WINDOW);
if Err <> 0 then Exit;
for i:=1 to 8 do
begin
   WavBuff := New(PWavArrayBuf);
   WaveHdr := New(PWaveHdr);
   with WaveHdr^ do
   begin
   lpData := Pointer(WavBuff);
     dwBufferLength := SizeOf(WavBuff);
     dwBytesRecorded := 0;
     dwUser := 0;
     dwFlags := 0;
     dwLoops := 0;
   end;
   Err := WaveInPrepareHeader(WaveIn^, WaveHdr, SizeOf(TWaveHdr));
   if Err <> 0 then
   begin
     FreeData;
     Exit;
   end;
   Err := WaveInAddBuffer(WaveIn^, WaveHdr, Sizeof(TWaveHdr));
   if Err <> 0 then
   begin
     FreeData;
     Exit;
   end;
end;
Err := WaveInStart(WaveIn^);
if Err <> 0 then
begin
   FreeData;
   Exit;
end;
Result := True;
end;
Procedure Tform1.WndProc(var Msg: TMessage);
var
Hdr: PWaveHdr;
I: Integer;
R: Real;
begin
inherited;
case Msg.Msg of
   MM_WIM_DATA:
  begin
     Hdr := PWaveHdr(Msg.LParam);
     if Hdr^.dwBytesRecorded = 0 then Exit;
     R := IfThen(Hdr^.dwBytesRecorded > 0,
       ClientWidth / Hdr^.dwBytesRecorded, 0);
     PatBlt(Canvas.Handle, 0, 0, ClientWidth,  ClientHeight, PATCOPY);
     Canvas.Pen.Color:=clRed;
     Canvas.MoveTo(0, 127);
     Canvas.LineTo(ClientWidth, 127);
     Canvas.Pen.Color := clMaroon;
     for I := 1 to 12 do
     begin
       Canvas.MoveTo(Round(R * (I * 100)), 0);
       Canvas.LineTo(Round(R * (I * 100)), 255);
     end;
     Canvas.Pen.Color:=clLime;
     Canvas.MoveTo(0, PWavArrayBuf(Hdr.lpData)^[0]);
    for I := 0 to Hdr^.dwBytesRecorded - 1 do
      Canvas.LineTo(Round(R * I), PWavArrayBuf(Hdr.lpData)^[I]);
     WaveInUnprepareHeader(WaveIn^, Hdr, Sizeof(TWaveHdr));
     Dispose(hdr.lpData);
     DisPose(hdr);
    Hdr := New(PWaveHdr);
     Hdr^.lpData := Pointer(New(PWavArrayBuf));
     Hdr^.dwBufferLength := 1024;
     Hdr^.dwBytesRecorded := 0;
     Hdr^.dwUser := 0;
     Hdr^.dwFlags := 0;
     Hdr^.dwLoops := 0;
     WaveInPrepareHeader(WaveIn^, Hdr, Sizeof(TWaveHdr));
     WaveInAddBuffer(WaveIn^, Hdr, Sizeof(TWaveHdr));
   end;
end;
end;
 
procedure TForm1.CloseWaveIn;
begin
WaveInStop(WaveIn^);
if WaveIn <> nil then
begin
   WaveInReset(WaveIn^);
   WaveInClose(WaveIn^);
end;
Dispose(WaveIn);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
Height := 282;
Width := 1000;
Color := clBlack;
if not InitWaveIn then ShowMessage(SysErrorMessage(GetLastError));
end;
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
CloseWaveIn;
end;

end.

Alexeis

Дата 17.9.2007, 12:55 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

http://forum.vingrad.ru/index.php?showtopic=89826

--------------------

RinOSpro

Дата 17.9.2007, 12:57 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Благодорю почитаю на досуге

Alexeis

Дата 17.9.2007, 13:02 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

Цитата(RinOSpro @ 17.9.2007, 12:57

)

Благодорю почитаю на досуге

На самом деле если не интересует теория, то можно просто глянуть самый последний пример, там чисто запись в файл выборок и ничего лишнего.

--------------------

Ak47black

Дата 17.9.2007, 21:01 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 2205
Регистрация: 2.12.2005

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

RinOSpro, вот пример еше есть в конце статьи(если его еше не видал) осталось тока скомпилировать.

RinOSpro

Дата 18.9.2007, 07:31 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Ak47black посмотрел, неплохо. Ты же вроде без использования VCL хотел. или я чтото не понял.

RinOSpro

Дата 18.9.2007, 08:07 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Я удалил все лишнее и получился вот такой модуль. только как его заставить работать ума не приложу.

Код


unit WaveRecord;

interface

uses Windows, Messages, MMSystem;

type

TWaveHeader = record
   Marker1:        Array[0..3] of Char;
   BytesFollowing: LongInt;
   Marker2:        Array[0..3] of Char;
   Marker3:        Array[0..3] of Char;
   Fixed1:         LongInt;
   FormatTag:      Word;
   Channels:       Word;
   SampleRate:     LongInt;
   BytesPerSecond: LongInt;
   BytesPerSample: Word;
   BitsPerSample:  Word;
   Marker4:        Array[0..3] of Char;
   DataBytes:      LongInt;
end;

var
    WaveHeader : TWaveHeader;
    fOut: file of byte;
    n:        integer;
    WaveData1:PChar;
    WaveData2:PChar;
    wfx:      TWaveFormatEx;
    wh1,wh2:  TWaveHdr;
    hwi:      HWAVEIN;
    address:  pWaveHdr;
    stop:     boolean;
    Channels,BitsPerSample,Rate,WaveDataLength,device: integer;

    procedure MMProcOpen(var Message: TMessage); message MM_WIM_OPEN;
    procedure MMProcClose(var Message: TMessage); message MM_WIM_CLOSE;
    procedure MMProcData(var Message: TMessage); message MM_WIM_DATA;
    procedure MakeHeader;
    procedure Records;
    function StartLoader(fname:string): MMResult;
    function StopLoader: MMResult;

implementation

procedure MMProcOpen(var Message: TMessage);
begin
   Exit;
end;

procedure MMProcClose(var Message: TMessage);
begin
   MakeHeader;
   CloseFile(fOut);
   GlobalFree(integer(WaveData1));
   GlobalFree(integer(WaveData2));
end;

procedure MMProcData(var Message: TMessage);
var
   temp: pWaveHdr;
   recorded: integer;
begin
   temp:=address;
   if address=@wh1 then address:=@wh2 else address:=@wh1;

   if not stop then
        waveInAddBuffer(hwi,address,sizeof(TWaveHdr));
   recorded:=address.dwBytesRecorded;
   BlockWrite(fOut,(temp.lpData)^,recorded);
   n:=n+recorded;
end;

function StartLoader(fname:string): MMResult;
begin
   n:=0;
   stop:=false;

   WaveData1:=PChar(
               GlobalAlloc(GMEM_FIXED or GMEM_NOCOMPACT or GMEM_NODISCARD,
               WaveDataLength));
   WaveData2:=PChar(
               GlobalAlloc(GMEM_FIXED or GMEM_NOCOMPACT or GMEM_NODISCARD,
               WaveDataLength));
   AssignFile(fOut,fname);
   ReWrite(fOut);
   // ðåçåðâèðóåì â ôàéëå ìåñòî ïîä çàãîëîâîê
   BlockWrite(fOut,WaveHeader,sizeof(TWaveHeader));
   // èíèöèàëèçàöèÿ ñòðóêòóðû äàííûõ
   wfx.nChannels:=       Channels;       // îäèí êàíàë - ÌÎÍÎ, 2- ÑÒÅÐÅÎ
   wfx.wFormatTag:=      WAVE_FORMAT_PCM;// ôîðìàò äàííûõ - PCM
   wfx.nSamplesPerSec:=  Rate;           // sample rate, Hz
   wfx.wBitsPerSample:=  BitsPerSample;  // áèò/âûáîðêó
   wfx.nBlockAlign:=     wfx.nChannels*wfx.wBitsPerSample div 8;
   wfx.nAvgBytesPerSec:= RATE*wfx.nChannels*wfx.wBitsPerSample div 8;
   wfx.cbSize:=          0;              // â äàííîì ñëó÷àå - èãíîðèðóåòñÿ
   Result:=waveInOpen(@hwi,device,@wfx,0,
                     0,CALLBACK_WINDOW);
   if Result<>MMSYSERR_NOERROR then Exit;
// ãîòîâèì çàãîëîâêè äëÿ äâóõ áóôåðîâ
   wh1.lpData:=WaveData1;
   wh1.dwBufferLength:=WaveDataLength*sizeof(byte);
   wh1.dwUser:=0;
   wh1.dwFlags:=0;

   wh2.lpData:=WaveData2;
   wh2.dwBufferLength:=WaveDataLength*sizeof(byte);
   wh2.dwUser:=0;
   wh2.dwFlags:=0;

   address:=@wh1;

   Result:=waveInPrepareHeader(hwi,@wh1,sizeof(TWaveHdr));
   if Result<>MMSYSERR_NOERROR then Exit;

   Result:=waveInPrepareHeader(hwi,@wh2,sizeof(TWaveHdr));
   if Result<>MMSYSERR_NOERROR then Exit;

// ñòàâèì ïåðâûé áóôåð â î÷åðåäü íà çàãðóçêó
   Result:=waveInAddBuffer(hwi,@wh1,sizeof(TWaveHdr));
   if Result<>MMSYSERR_NOERROR then Exit;
// çàïóñêàå îöèôðîâêó
   Result:=waveInStart(hwi);
   if Result<>MMSYSERR_NOERROR then Exit;
end;
//--------------------------------------------------------------------
function StopLoader: MMResult;
begin
   stop:=true;  // ôëàã îñòàíîâêè
   Result:=waveInReset(hwi);
   Result:=Result or waveInClose(hwi);
end;
//--------------------------------------------------------------------
procedure MakeHeader;
begin
   with WaveHeader do
   begin
      Marker1 := 'RIFF';
      BytesFollowing := n + 36;
      Marker2 := 'WAVE';
      Marker3 := 'fmt ';
      Fixed1 := 16;
      FormatTag := 1;
      SampleRate := Rate;
      Channels := Channels;
      BytesPerSecond := Channels;
      BytesPerSecond := WaveHeader.BytesPerSecond * Rate;
      BytesPerSecond := WaveHeader.BytesPerSecond * BitsPerSample;
      BytesPerSecond := WaveHeader.BytesPerSecond div 8;
      BytesPerSample := Channels * BitsPerSample div 8;
      BitsPerSample := BitsPerSample;
      Marker4 := 'data';
      DataBytes := n;
   end;
   Reset(fOut);
   BlockWrite(fOut,WaveHeader,sizeof(TWaveHeader));
end;

procedure Records;
var
   res: MMResult;
   msg: array [0..255] of char;
begin
      res:=StartLoader('1.wav');
      if res<>MMSYSERR_NOERROR then
      begin
         waveInGetErrorText(res,msg,256);
      end;
   end;

procedure StopClick(Sender: TObject);
begin
   StopLoader;
end;

end.

Подскажите

Это сообщение отредактировал(а) RinOSpro - 18.9.2007, 08:24

Alexeis

Дата 18.9.2007, 08:58 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 55
Всего: 459

Цитата(RinOSpro @ 18.9.2007, 08:07

)

только как его заставить работать ума не приложу.

Отлаживать. Если хватило знаний объединить, то нужно учиться и отлаживать. Ctrl+F5 - добавляет переменную в список просмотра, F8 идет по коду не заходя в него F5 ставит точку останова к коде F4 перескакивает от брейка к брейку, F7 заходит внутрь процедуры при пошаговой отладке. Так что садись на боевого коня Delphi и вперед за ошибками smile

--------------------

RinOSpro

Дата 18.9.2007, 09:26 (ссылка)

(голосов: 0)

Загрузка ...

Unregistered

Цитата(Alexeis @ 18.9.2007, 08:58

)

F5 ставит точку останова к коде F4 перескакивает от брейка к брейку, F7 заходит внутрь процедуры при пошаговой

не в этом дело

а в том в каком порядке вызывать процедуры и с какими параметрами

Ak47black

Дата 18.9.2007, 18:45 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 2205
Регистрация: 2.12.2005

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

RinOSpro, Тебе надо в MSDN посмотреть, там на каждую функцию подробное описание.

Цитата

а в том в каком порядке вызывать процедуры и с какими параметрами

Тут как в примере (ссылку которого я тебе давал), просто проверь правильно-ли ты перекопировал. Пример же полностью рабочий.

Цитата

Ты же вроде без использования VCL хотел

Не тут виндовские функции.
Просто для ввода используется VCL.

Это сообщение отредактировал(а) Ak47black - 18.9.2007, 18:51

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Звук, графика и видео \| Следующая тема »