Playing PCM Wav File in Delphi - delphi

I have written a simple code that reads the header of a Wav File and then starts playing it. this is my code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Generics.collections,
Vcl.ExtCtrls, MMSystem;
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
Label1: TLabel;
Label2: TLabel;
Shape1: TShape;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TWaveformSample = integer; // signed 32-bit; -2147483648..2147483647
TWaveformSamples = packed array of TWaveformSample; // one channel
var
Form1: TForm1;
myWavFile: file;
DataBlock: array[0..3] of byte;
Count: integer;
NumOfChannels: integer;
SampleRate: integer;
BytesPerSecond: integer;
ByesPerSample: integer;
BitsPerSample: integer;
CompressionCode: integer;
CompressionDesc: string;
BlockAlign: integer;
ExtraFormatBytes: integer;
CompressionCodes: TDictionary<integer, string>;
BytesRead: integer;
Samples: TWaveformSamples;
fmt: TWaveFormatEx;
PacketIsPlaying: Boolean;
implementation
{$R *.dfm}
procedure InitAudioSys;
begin
with fmt do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := NumOfChannels;
nSamplesPerSec := SampleRate;
wBitsPerSample := BitsPerSample;
nAvgBytesPerSec := nChannels * nSamplesPerSec * wBitsPerSample div 8;
nBlockAlign := nChannels * wBitsPerSample div 8;
cbSize := 0;
end;
end;
procedure PlaySound;
var
wo: integer;
hdr: TWaveHdr;
begin
if Length(samples) = 0 then
begin
Writeln('Error: No audio has been created yet.');
Exit;
end;
if waveOutOpen(#wo, WAVE_MAPPER, #fmt, 0, 0, CALLBACK_NULL) = MMSYSERR_NOERROR then
try
PacketIsPlaying := True;
ZeroMemory(#hdr, sizeof(hdr));
with hdr do
begin
lpData := #samples[0];
dwBufferLength := fmt.nChannels * Length(Samples) * sizeof(TWaveformSample);
dwFlags := 0;
end;
waveOutPrepareHeader(wo, #hdr, sizeof(hdr));
waveOutWrite(wo, #hdr, sizeof(hdr));
//sleep(450);
//while waveOutUnprepareHeader(wo, #hdr, sizeof(hdr)) = WAVERR_STILLPLAYING do
//sleep(100);
finally
waveOutClose(wo);
PacketIsPlaying := False;
end;
end;
function ReadDataBlock(Size: integer): Boolean;
begin
try
BlockRead(myWavFile, DataBlock, Size, Count);
INC(BytesRead, Size);
Result := True;
except
Result := False;
end;
end;
function OpenWav(FileName: string): Boolean;
begin
try
Assignfile(myWavFile, filename);
Reset(myWavFile, 1);
Result := True;
except
Result := False;
end;
end;
function CloseWav: Boolean;
begin
try
CloseFile(myWavFile);
Result := True;
except
Result := False;
end;
end;
function ValidateWav: Boolean;
const
RIFF: array[0..3] of byte = (82, 73, 70, 70);
WAVE: array[0..3] of byte = (87, 65, 86, 69);
_FMT: array[0..3] of byte = (102, 109, 116, 32);
FACT: array[0..3] of byte = (102, 97, 99, 116);
DATA: array[0..3] of byte = (100, 97, 116, 97);
_DATA: array[0..3] of byte = (64, 61, 74, 61);
var
RiffChunkSize, FmtChunkSize, FactChunkSize, DataChunkSize, i, j, tmp, Freq: integer;
omega,
dt, t: double;
vol: double;
begin
BytesRead := 0;
//Check "RIFF"
ReadDataBlock(4);
if not CompareMem(#DataBlock, #RIFF, SizeOf(DataBlock)) then
begin
Result := False;
Exit;
end;
//Get "RIFF" Chunk Data Size
ReadDataBlock(4);
Move(DataBlock, RiffChunkSize, 4);
//Check "WAVE"
ReadDataBlock(4);
if not CompareMem(#DataBlock, #WAVE, SizeOf(DataBlock)) then
begin
Result := False;
Exit;
end;
{FMT ---------------------------------------------------------------------}
//Check "FMT"
ReadDataBlock(4);
if not CompareMem(#DataBlock, #_FMT, SizeOf(DataBlock)) then
begin
Result := False;
Exit;
end;
//Get "FMT" Chunk Data Size
ReadDataBlock(4);
Move(DataBlock, FmtChunkSize, 4);
BytesRead := 0;
//Get Wav Compression Code
ReadDataBlock(2);
Move(DataBlock, CompressionCode, 2);
if not CompressionCodes.TryGetValue(CompressionCode, CompressionDesc) then
CompressionDesc := 'File Error!';
//Get Number of Channels
ReadDataBlock(2);
Move(DataBlock, NumOfChannels, 2);
//Get Sample Rate
ReadDataBlock(4);
Move(DataBlock, SampleRate, 4);
//Get Average Bytes Per Second
ReadDataBlock(4);
Move(DataBlock, BytesPerSecond, 4);
//Get Block Align
ReadDataBlock(2);
Move(DataBlock, BlockAlign, 2);
//Get Bits Per Sample
ReadDataBlock(2);
Move(DataBlock, BitsPerSample, 2);
//Extra Format Bytes
if BytesRead <= FmtChunkSize - 2 then
begin
ReadDataBlock(2);
Move(DataBlock, ExtraFormatBytes, 2);
end;
//If it's not Uncompressed/PCM File, then we have Extra Format Bytes
if CompressionCode <> 1 then
begin
//Skip Compression Data
for i := 0 to FmtChunkSize - BytesRead - 1 do
ReadDataBlock(1);
Result := False;
Exit;
end;
{FACT --------------------------------------------------------------------}
{FactChunkSize := 0;
//Check "FACT"
ReadDataBlock(4);
if CompareMem(#DataBlock, #FACT, SizeOf(DataBlock)) then
begin
//Get "FMT" Chunk Data Size
ReadDataBlock(4);
Move(DataBlock, FactChunkSize, 4);
BytesRead := 0;
for i := 0 to FactChunkSize - BytesRead - 1 do
ReadDataBlock(1);
end; }
{DATA ------------------------------------------------------------------}
while BytesRead < FmtChunkSize do
ReadDataBlock(1);
BytesRead := 0;
//Skip bytes until "data" shows up
while (not CompareMem(#DataBlock, #DATA, SizeOf(DataBlock))) and (not CompareMem(#DataBlock, #_DATA, SizeOf(DataBlock))) do
begin
ReadDataBlock(4);
end;
ReadDataBlock(4);
Move(DataBlock, DataChunkSize, 4);
Form1.Label1.Caption := 'Compression Code: ' + IntToStr(CompressionCode) + #10#13 +
'Compression Description: ' + CompressionDesc + #10#13 +
'Number of Channels: ' + IntToStr(NumOfChannels) + #10#13 +
'Sample Rate: ' + IntToStr(SampleRate) + #10#13 +
'Byes per Sample: ' + IntToStr(ByesPerSample) + #10#13 +
'Byes per Second: ' + IntToStr(BytesPerSecond) + #10#13 +
'Bits per Second: ' + IntToStr(BitsPerSample);
tmp := FileSize(myWavFile) - DataChunkSize;
{ j := 0;
Form1.Image1.Canvas.Rectangle(0, 0, Form1.Image1.Width, Form1.Image1.Height);
for i := 0 to (DataChunkSize div 20) do
begin
//BlockRead(myWavFile, DataBlock, 76, Count);
tmp := tmp + 76;
Seek(myWavFile, tmp);
ReadDataBlock(4);
Move(DataBlock, Freq, 4);
if i mod ((DataChunkSize div 80) div Form1.Image1.Width) = 0 then
begin
INC(J);
Form1.Image1.Canvas.MoveTo(j, 121 div 2);
Form1.Image1.Canvas.LineTo(j, (121 div 2) - Trunc((Freq / High(Integer)) * (121 div 2)));
end;
Application.ProcessMessages;
end;
Seek(myWavFile, FileSize(myWavFile) - DataChunkSize); }
InitAudioSys;
PacketIsPlaying := False;
SetLength(Samples, fmt.nSamplesPerSec);
while PacketIsPlaying = false do
begin
for i := 0 to fmt.nSamplesPerSec do
begin
ReadDataBlock(4);
Move(DataBlock, Freq, 4);
Samples[i] := Freq;
end;
PlaySound;
Sleep(2000);
Application.ProcessMessages;
end;
Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
f: file;
b: array[0..3] of byte;
count: integer;
begin
with opendialog1 do
if execute then
begin
Form1.Image1.Canvas.Rectangle(0, 0, Form1.Image1.Width, Form1.Image1.Height);
Label1.Font.Color := clBlack;
OpenWav(FileName);
if ValidateWav = False then
begin
Label1.Caption := 'Invalid File Data!';
Label1.Font.Color := clRed;
Exit;
end;
CloseWav;
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
CompressionCodes.Destroy;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Image1.Canvas.Rectangle(0, 0, Image1.Width, Image1.Height);
CompressionCodes := TDictionary<integer, string>.Create;
CompressionCodes.Add(0, 'Unknown');
CompressionCodes.Add(1, 'PCM/Uncompressed');
CompressionCodes.Add(2, 'Microsoft ADPCM');
CompressionCodes.Add(6, 'ITU G.711 a-law');
CompressionCodes.Add(7, 'ITU G.711 µ-law');
CompressionCodes.Add(17, 'IMA ADPCM');
CompressionCodes.Add(20, 'ITU G.723 ADPCM (Yamaha)');
CompressionCodes.Add(49, 'GSM 6.10');
CompressionCodes.Add(64, 'ITU G.721 ADPCM');
CompressionCodes.Add(80, 'MPEG');
CompressionCodes.Add(85, 'ISO/MPEG');
CompressionCodes.Add(65536, 'Experimental');
end;
end.
The Code needs a TLabel, a Tbutton and an OpenFileDialog on the form.
I have problem with the File Playback. currently I create arrays of samples with the length of SamplesPerSecond and play them one after another with the delay of 2000 (delays less than 2000ms will raise error).
What I want now is how can I Read samples and play them one after another smoothly and without delay. and Also I want to be able to visualize every few samples on a graph as the file is being played.

Funny you post this when you did, because I just yesterday wrote a working WAV player using Microsoft's waveOut... API.
You are not reading through the RIFF chunks effectively/correctly. I strongly suggest you use Microsoft's Multimedia functions (mmioOpen(), mmioDescend(), mmioAscend() and mmioRead()) instead of using AssignFile() and BlockRead(). WAV files are more complicated than you think, the code you have shown is not flexible enough to handle everything it may encounter. For instance, FMT is not always the first chunk in a WAV file, and there may be other chunks present before the DATA chunk, which you are not skipping.
When using waveOutOpen(), you should pass the original WAVEFORMATEX as read from the file, rather than creating a new WAVEFORMATEX that you populate with interpreted values. Using MMIO functions, you can declare a WAVEFORMATEX variable, mmioDescend() into the FMT chunk, mmioRead() the entire chunk directly into the variable, and then pass the variable as-is to waveOutOpen().
When using waveOutWrite(), you should use multiple audio buffers that you loop through (you can pre-prepare them with waveOutPrepareHeader() before you start reading the audio sample data, so you are only preparing them once). If you supply the wave device with only one buffer at a time, you are likely to get choppy audio playback (which it sounds like you are). It is best to use at least 3 buffers (my player uses 20, but I may knock that back later):
Fill 2 buffers with sample data and pass them to waveOutWrite() right away, and fill the 3rd buffer while they are playing.
When your waveOutOpen() callback says the 1st buffer is done playing, pass the 3rd buffer to waveOutWrite() and fill the 1st buffer with new data.
When the callback says the 2nd buffer is done playing, pass the 1st buffer to waveOutWrite() and fill the 2nd buffer with new data.
When the callback says the 3rd buffer is done playing, pass the 2nd buffer to waveOutWrite() and fill the 3rd buffer with new data.
And so on, continuing this round-robin logic until the end of the DATA chunk is reached.
The wave device should always have at least 2 active audio buffers playing at any given time to avoid gaps in the playback. Let the callback tell you when each buffer is done so you can provide the next buffer.
I based my player code on David Overton's tutorial, which has a LOT of information, and code examples:
Playing Audio in Windows using waveOut Interface
http://www.et.hs-wismar.de/~litschke/TMS/Audioprogrammierung.pdf
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=4422&lngWId=3
The only tweaks I made to the tutorial's code was to:
using MMIO functions for file I/O.
using the RTL's memory management functions instead of OS memory functions.
changed the size of the audio buffers. David uses 8KB buffers, which I found caused garbage playback after a few seconds as the wave device was not being fed audio samples fast enough for my WAV files (which are GSM encoded, not PCM, so they have smaller sample sizes). I changed the buffer size to the nAvgBytesPerSec value reported by the FMT chunk, and then the audio played cleanly all the way through.
error handling.
Try this (translated to Delphi from my real code written in C++):
{
The following is based on code written by David Overton:
Playing Audio in Windows using waveOut Interface
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=4422&lngWId=3
https://www.et.hs-wismar.de/~litschke/TMS/Audioprogrammierung.pdf
But with some custom tweaks.
}
uses
..., Winapi.Windows, Winapi.MMSystem;
const
BLOCK_COUNT = 20;
procedure waveOutProc(hWaveOut: HWAVEOUT; uMsg: UINT; dwInstance, dwParam1, dwParam2: DWORD_PTR): stdcall; forward;
function writeAudio(hWaveOut: HWAVEOUT; data: PByte; size: Integer): Boolean; forward;
var
waveCriticalSection: CRITICAL_SECTION;
waveBlocks: PWaveHdr;
waveFreeBlockCount: Integer;
waveCurrentBlock: Integer;
buffer: array[0..1023] of Byte;
mmckinfoParent: MMCKINFO;
mmckinfoSubchunk: MMCKINFO;
dwFmtSize: DWORD;
dwDataSize: DWORD;
dwSizeToRead: DWORD;
hmmio: HMMIO;
wfxBuffer: array of Byte;
wfx: PWaveFormatEx;
hWaveOut: HWAVEOUT;
blockBuffer: array of Byte;
pBlockData: PByte;
i: Integer;
readBytes: LONG;
begin
...
hmmio := mmioOpen(PChar(FileName), nil, MMIO_READ or MMIO_DENYWRITE);
if hmmio = 0 then
raise Exception.Create('Unable to open WAV file');
try
mmckinfoParent.fccType := mmioStringToFOURCC('WAVE', 0);
if mmioDescend(hmmio, #mmckinfoParent, nil, MMIO_FINDRIFF) <> MMSYSERR_NOERROR then
raise Exception.CreateFmt('%s is not a WAVE file', [FileName]);
mmckinfoSubchunk.ckid := mmioStringToFOURCC('fmt', 0);
if mmioDescend(hmmio, #mmckinfoSubchunk, #mmckinfoParent, MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
raise Exception.Create('File has no FMT chunk');
dwFmtSize := mmckinfoSubchunk.cksize;
if dwFmtSize = 0 then
raise Exception.Create('File FMT chunk is empty');
SetLength(wfxBuffer, dwFmtSize);
wfx := PWaveFormatEx(Pointer(wfxBuffer));
if mmioRead(hmmio, PAnsiChar(wfx), dwFmtSize) <> dwFmtSize then
raise Exception.Create('Failed to read FMT chunk');
if mmioAscend(hmmio, #mmckinfoSubchunk, 0) <> MMSYSERR_NOERROR then
raise Exception.Create('Failed to ascend into RIFF chunk');
mmckinfoSubchunk.ckid := mmioStringToFOURCC('data', 0);
if mmioDescend(hmmio, #mmckinfoSubchunk, #mmckinfoParent, MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
raise Exception.Create('File has no DATA chunk');
dwDataSize := mmckinfoSubchunk.cksize;
if dwDataSize <> 0 then
begin
hWaveOut := 0;
if waveOutOpen(#hWaveOut, WAVE_MAPPER, wfx, DWORD_PTR(#waveOutProc), 0, CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
raise Exception.Create('Unable to open wave mapper device');
try
SetLength(blockBuffer, (sizeof(WAVEHDR) + wfx.nAvgBytesPerSec) * BLOCK_COUNT);
pBlockData := PByte(blockBuffer);
waveBlocks := PWaveHdr(pBlockData);
Inc(pBlockData, sizeof(WAVEHDR) * BLOCK_COUNT);
for i := 0 to BLOCK_COUNT-1 do
begin
ZeroMemory(#waveBlocks[i], sizeof(WAVEHDR));
waveBlocks[i].dwBufferLength := wfx.nAvgBytesPerSec;
waveBlocks[i].lpData := pBlockData;
if waveOutPrepareHeader(hWaveOut, #waveBlocks[i], sizeof(WAVEHDR)) <> MMSYSERR_NOERROR then
raise Exception.Create('Failed to prepare a WAV audio header');
Inc(pBlockData, wfx.nAvgBytesPerSec);
end;
waveFreeBlockCount := BLOCK_COUNT;
waveCurrentBlock := 0;
InitializeCriticalSection(#waveCriticalSection);
try
repeat
dwSizeToRead := Min(dwDataSize, sizeof(buffer));
readBytes := mmioRead(hmmio, PAnsiChar(buffer), dwSizeToRead);
if readBytes <= 0 then Break;
if readBytes < sizeof(buffer) then
ZeroMemory(#buffer[readBytes], sizeof(buffer) - readBytes);
writeAudio(hWaveOut, buffer, sizeof(buffer));
Dec(dwDataSize, readBytes);
until dwDataSize = 0;
writeAudio(hWaveOut, nil, 0);
while waveFreeBlockCount < BLOCK_COUNT do
Sleep(10);
for i := 0 to BLOCK_COUNT-1 do
begin
if (waveBlocks[i].dwFlags and WHDR_PREPARED) <> 0 then
waveOutUnprepareHeader(hWaveOut, #waveBlocks[i], sizeof(WAVEHDR));
end;
finally
DeleteCriticalSection(#waveCriticalSection);
end;
finally
waveOutClose(hWaveOut);
end;
end;
finally
mmioClose(hmmio, 0);
end;
end;
procedure waveOutProc(hWaveOut: HWAVEOUT; uMsg: UINT; dwInstance, dwParam1, dwParam2: DWORD_PTR); stdcall;
begin
if uMsg = WOM_DONE then
begin
EnterCriticalSection(&waveCriticalSection);
Inc(waveFreeBlockCount);
LeaveCriticalSection(&waveCriticalSection);
end;
end;
procedure writeAudio(hWaveOut: HWAVEOUT; data: PByte; size: Integer);
var
current: PWaveHdr;
remaining: Integer;
begin
current := #waveBlocks[waveCurrentBlock];
if data = nil then
begin
if current.dwUser <> 0 then
begin
if current.dwUser < current.dwBufferLength then
begin
remaining := Integer(current.dwBufferLength - current.dwUser);
ZeroMemory(current.lpData + current.dwUser, remaining);
Inc(current.dwUser, remainint);
end;
EnterCriticalSection(&waveCriticalSection);
Dec(waveFreeBlockCount);
LeaveCriticalSection(&waveCriticalSection);
if waveOutWrite(hWaveOut, current, sizeof(WAVEHDR)) <> MMSYSERR_NOERROR then
raise Exception.Create('Failed to write a WAV audio header');
end;
end else
begin
while size > 0 do
begin
remaining := Integer(current.dwBufferLength - current.dwUser);
if size < remaining then
begin
Move(data^, (current.lpData + current.dwUser)^, size);
Inc(current.dwUser, size);
Break;
end;
Move(data^, (current.lpData + current.dwUser)^, remaining);
Inc(current.dwUser, remaining);
Inc(data, remaining);
Dec(size, remaining);
EnterCriticalSection(&waveCriticalSection);
Dec(waveFreeBlockCount);
LeaveCriticalSection(&waveCriticalSection);
if waveOutWrite(hWaveOut, current, sizeof(WAVEHDR)) <> MMSYSERR_NOERROR then
raise Exception.Create('Failed to write a WAV audio header');
while waveFreeBlockCount = 0 do
Sleep(10);
Inc(waveCurrentBlock);
waveCurrentBlock := waveCurrentBlock mod BLOCK_COUNT;
current := #waveBlocks[waveCurrentBlock];
current.dwUser := 0;
end;
end;
end;
Regarding visualization of the samples, you are best off using a 3rd party component for that (and you probably should be using a 3rd party WAV player anyway, instead of writing API code manually), such as Mitov Software's AudioLab components.

UINT is an unsigned 32 bit integer which is not used in Delphi. Change UINT to "cardinal", which is Delphi's 32 bit unsigned integer.
Ian

Related

Using delphi to capture mic audio in LINEAR16

From SO I get the next unit code to capture Mic Audio.
I´d like to use the audio captured to send to google speech recognize api.
The google speech api accepts only some encoded formats.
I need the audio in LINEAR16 Uncompressed 16-bit signed little-endian samples.
How could I modify this code to do it?
Sample of use:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SNDProcWaveIn(ind);
//code for proc data in "ind" buffer
end;
unit WaveSound;
interface
uses
SysUtils, MMSystem;
const
NUMSAMPLES = 1024; // Number of Samples
type
TIndata = array[0 .. NUMSAMPLES - 1] of Integer;
PIndata = ^TIndata;
TFrec= record
Fx, dx :Integer;
end;
function SNDInitWaveIn: Cardinal;
procedure SNDProcWaveIn(var Indata : TIndata);
procedure SNDStopWave;
implementation
var
DevHandle : Integer;
WAVEFORMAT1 : TWAVEFORMATEX;
Wave : WAVEHDR;
function SNDInitWaveIn: Cardinal;
begin
with WAVEFORMAT1 do begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1;
nSamplesPerSec := 44100;// 11025; //11khz
wBitsPerSample := 16;
nBlockAlign := (nChannels * wBitsPerSample) div 8;
nAvgBytesPerSec := nBlockAlign * nSamplesPerSec;
cbSize := 0;
end;
Result:= waveInOpen(#DevHandle, cardinal(-1),#WAVEFORMAT1, cardinal(0), cardinal(0), cardinal(0));
If not(DevHandle = 0) Then waveInStart(DevHandle);
end;
procedure SNDProcWaveIn(var Indata : TIndata);
begin
//lpdata requires the address of an array to fill up data with
Wave.lpData := #Indata;
//the buffer length
Wave.dwBufferLength := NUMSAMPLES;
Wave.dwFlags := 0;
//prepare device for input
waveInPrepareHeader(DevHandle, #Wave, sizeof(Wave));
waveInAddBuffer(DevHandle, #Wave, sizeof(Wave));
// if the following statement is removed, the vis. will be a lot faster (avs style)
// but uses up 100% of cpu!
// this is why i hate avs
Sleep(10); // give device a breather
// the following loop is quite useless, but anyway...
repeat
//Just wait for the blocks to be done or the device to close
until (((Wave.dwFlags and WHDR_DONE)= WHDR_DONE) or (DevHandle = 0));
If (DevHandle = 0) Then Exit; //Cut out if the device is closed
waveInUnprepareHeader(DevHandle, #Wave, sizeof(Wave));
end;
procedure SNDStopWave;
begin
waveInReset(DevHandle);
waveInClose(DevHandle);
DevHandle := 0;
end;
end.

Creating flac file or flac stream using BASS dll with Delphi

I am playing with BASS from http://www.un4seen.com/.
I need to create a flac file(16bits) or flac stream from user speaking on Microphone.
I have seen this demo in BASS source code.
There is a bassenc_flac.dll as well with these functions:
function BASS_Encode_FLAC_Start(handle:DWORD; options:PChar; flags:DWORD; proc:ENCODEPROCEX; user:Pointer): HENCODE; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; external bassencflacdll;
function BASS_Encode_FLAC_StartFile(handle:DWORD; options:PChar; flags:DWORD; filename:PChar): HENCODE; {$IFDEF MSWINDOWS}stdcall{$ELSE}cdecl{$ENDIF}; external bassencflacdll;
How could I change the next code to encode the audio to flac file or stream?
From RecordTest BASS demo
(* This is called while recording audio *)
function RecordingCallback(Handle: HRECORD; buffer: Pointer; length: DWORD; user: Pointer): boolean; stdcall;
var level:dword;
begin
level:=BASS_ChannelGetLevel(Handle);
// Copy new buffer contents to the memory buffer
Form1.WaveStream.Write(buffer^, length);
// Allow recording to continue
Result := True;
end;
(* Start recording to memory *)
procedure TForm1.StartRecording;
begin
if ComboBox1.ItemIndex < 0 then Exit;
if WaveStream.Size > 0 then
begin // free old recording
BASS_StreamFree(chan);
WaveStream.Clear;
end;
// generate header for WAV file
with WaveHdr do
begin
riff := 'RIFF';
len := 36;
cWavFmt := 'WAVEfmt ';
dwHdrLen := 16;
wFormat := 1;
wNumChannels := 2;
dwSampleRate := 44100;
wBlockAlign := 4;
dwBytesPerSec := 176400;
wBitsPerSample := 16;
cData := 'data';
dwDataLen := 0;
end;
WaveStream.Write(WaveHdr, SizeOf(WAVHDR));
// start recording # 44100hz 16-bit stereo
rchan := BASS_RecordStart(44100, 2, 0, #RecordingCallback, nil);
if rchan = 0 then
begin
MessageDlg('Couldn''t start recording!', mtError, [mbOk], 0);
WaveStream.Clear;
end
else
begin
bRecord.Caption := 'Stop';
bPlay.Enabled := False;
bSave.Enabled := False;
end;
end;
(* Stop recording *)
procedure TForm1.StopRecording;
var
i: integer;
he:BassEnc.HENCODE;
begin
BASS_ChannelStop(rchan);
bRecord.Caption := 'Record';
// complete the WAV header
WaveStream.Position := 4;
i := WaveStream.Size - 8;
WaveStream.Write(i, 4);
i := i - $24;
WaveStream.Position := 40;
WaveStream.Write(i, 4);
WaveStream.Position := 0;
// create a stream from the recorded data
chan := BASS_StreamCreateFile(True, WaveStream.Memory, 0, WaveStream.Size, 0);
if chan <> 0 then
begin
// enable "Play" & "Save" buttons
bPlay.Enabled := True;
bSave.Enabled := True;
end
else
MessageDlg('Error creating stream from recorded data!', mtError, [mbOk], 0);
if SaveDialog.Execute then
WaveStream.SaveToFile(SaveDialog.FileName);
end;
I have updated code because of comments that show incorrect work of previous encoder version. And I am totally agree with these comments.
In order to create an encoder to FLAC we should go to un4seen web-site and download the next files:
BASS audio library 2.4
BASSFLAC 2.4.4
BASSenc 2.4.14
BASSenc_FLAC 2.4.1.1
Go through these folders and look for the next files:
bass.pas
bassenc.pas
bassenc_flac.pas
Now place these pas-files into one folder and add it to Library via Delphi's options.
After this step create new project, save it in separate folder.
Then go through BASS_XXX folders and look for *.dll files.
Combine them together in the folder where you have saved your project!
Now let's write some code.
Add to the uses clause bass.pas, bassenc.pas and bassenc_flac.pas. Then copy the code shown below.
uses ..., BASS, BASSEnc, BASSEnc_FLAC;
...
TForm1 = class(TForm)
ProgressBar1: TProgressBar;
public
{ Public declarations }
procedure StartEncode(SourceFileName, OutputFileName: String);
procedure StopEncode;
end;
...
procedure TForm1.StartEncode(SourceFileName, OutputFileName: String);
var
PercentDone: Cardinal;
Buffer: array [0..1024] of Byte;
begin
Channel := BASS_StreamCreateFile(false, PChar(SourceFileName), 0, 0, BASS_MUSIC_DECODE or BASS_UNICODE);
BASSEnc_FLAC.BASS_Encode_FLAC_StartFile(Channel, 0, BASS_ENCODE_FP_AUTO or BASS_UNICODE, PChar(OutputFileName));
while BASS_ChannelIsActive(Channel) > 0 do
begin
BASS_ChannelGetData(Channel, #Buffer, 1024);
PercentDone := Trunc(100 * (BASS_ChannelGetPosition(Channel, BASS_POS_BYTE) / BASS_ChannelGetLength(Channel, BASS_POS_BYTE)));
ProgressBar1.Position := PercentDone;
end;
StopEncode;
end;
procedure TForm1.StopEncode;
begin
BASS_Encode_Stop(Channel);
BASS_StreamFree(Channel);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
BASS_Init(-1, 44100, 0, Application.Handle, nil);
try
// Set name of file to convert it to FLAC and save it with output name
StartEncode('SourceFileName', 'OutputFileName');
finally
BASS.BASS_Free;
end;
end;
One notice:
Indeed, file encoded with previous version of the code had incorrect header (I could see it when opened file in Notepad.exe). After code has been updated I can see valid header (in Notepad, of course, because I have no professional instruments for work with audio-files).
Now you even have no need to add plugin to BASS as I did earlier.
Since this I think that the encoder works as it was expected.

Find and Replace Text in a Large TextFile (Delphi XE5)

I am trying to find and replace text in a text file. I have been able to do this in the past with methods like:
procedure SmallFileFindAndReplace(FileName, Find, ReplaceWith: string);
begin
with TStringList.Create do
begin
LoadFromFile(FileName);
Text := StringReplace(Text, Find, ReplaceWith, [rfReplaceAll, rfIgnoreCase]);
SaveToFile(FileName);
Free;
end;
end;
The above works fine when a file is relatively small, however; when the the file size is something like 170 Mb the above code will cause the following error:
EOutOfMemory with message 'Out of memory'
I have tried the following with success, however it takes a long time to run:
procedure Tfrm_Main.button_MakeReplacementClick(Sender: TObject);
var
fs : TFileStream;
s : AnsiString;
//s : string;
begin
fs := TFileStream.Create(edit_SQLFile.Text, fmOpenread or fmShareDenyNone);
try
SetLength(S, fs.Size);
fs.ReadBuffer(S[1], fs.Size);
finally
fs.Free;
end;
s := StringReplace(s, edit_Find.Text, edit_Replace.Text, [rfReplaceAll, rfIgnoreCase]);
fs := TFileStream.Create(edit_SQLFile.Text, fmCreate);
try
fs.WriteBuffer(S[1], Length(S));
finally
fs.Free;
end;
end;
I am new to "Streams" and working with buffers.
Is there a better way to do this?
Thank You.
You have two mistakes in first code example and three - in second example:
Do not load whole large file in memory, especially in 32bit application. If file size more than ~1 Gb, you always get "Out of memory"
StringReplace slows with large strings, because of repeated memory reallocation
In second code you don`t use text encoding in file, so (for Windows) your code "think" that file has UCS2 encoding (two bytes per character). But what you get, if file encoding is Ansi (one byte per character) or UTF8 (variable size of char)?
Thus, for correct find&replace you must use file encoding and read/write parts of file, as LU RD said:
interface
uses
System.Classes,
System.SysUtils;
type
TFileSearchReplace = class(TObject)
private
FSourceFile: TFileStream;
FtmpFile: TFileStream;
FEncoding: TEncoding;
public
constructor Create(const AFileName: string);
destructor Destroy; override;
procedure Replace(const AFrom, ATo: string; ReplaceFlags: TReplaceFlags);
end;
implementation
uses
System.IOUtils,
System.StrUtils;
function Max(const A, B: Integer): Integer;
begin
if A > B then
Result := A
else
Result := B;
end;
{ TFileSearchReplace }
constructor TFileSearchReplace.Create(const AFileName: string);
begin
inherited Create;
FSourceFile := TFileStream.Create(AFileName, fmOpenReadWrite);
FtmpFile := TFileStream.Create(ChangeFileExt(AFileName, '.tmp'), fmCreate);
end;
destructor TFileSearchReplace.Destroy;
var
tmpFileName: string;
begin
if Assigned(FtmpFile) then
tmpFileName := FtmpFile.FileName;
FreeAndNil(FtmpFile);
FreeAndNil(FSourceFile);
TFile.Delete(tmpFileName);
inherited;
end;
procedure TFileSearchReplace.Replace(const AFrom, ATo: string;
ReplaceFlags: TReplaceFlags);
procedure CopyPreamble;
var
PreambleSize: Integer;
PreambleBuf: TBytes;
begin
// Copy Encoding preamble
SetLength(PreambleBuf, 100);
FSourceFile.Read(PreambleBuf, Length(PreambleBuf));
FSourceFile.Seek(0, soBeginning);
PreambleSize := TEncoding.GetBufferEncoding(PreambleBuf, FEncoding);
if PreambleSize <> 0 then
FtmpFile.CopyFrom(FSourceFile, PreambleSize);
end;
function GetLastIndex(const Str, SubStr: string): Integer;
var
i: Integer;
tmpSubStr, tmpStr: string;
begin
if not(rfIgnoreCase in ReplaceFlags) then
begin
i := Pos(SubStr, Str);
Result := i;
while i > 0 do
begin
i := PosEx(SubStr, Str, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(SubStr) - 1);
end
else
begin
tmpStr := UpperCase(Str);
tmpSubStr := UpperCase(SubStr);
i := Pos(tmpSubStr, tmpStr);
Result := i;
while i > 0 do
begin
i := PosEx(tmpSubStr, tmpStr, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(tmpSubStr) - 1);
end;
end;
var
SourceSize: int64;
procedure ParseBuffer(Buf: TBytes; var IsReplaced: Boolean);
var
i: Integer;
ReadedBufLen: Integer;
BufStr: string;
DestBytes: TBytes;
LastIndex: Integer;
begin
if IsReplaced and (not(rfReplaceAll in ReplaceFlags)) then
begin
FtmpFile.Write(Buf, Length(Buf));
Exit;
end;
// 1. Get chars from buffer
ReadedBufLen := 0;
for i := Length(Buf) downto 0 do
if FEncoding.GetCharCount(Buf, 0, i) <> 0 then
begin
ReadedBufLen := i;
Break;
end;
if ReadedBufLen = 0 then
raise EEncodingError.Create('Cant convert bytes to str');
FSourceFile.Seek(ReadedBufLen - Length(Buf), soCurrent);
BufStr := FEncoding.GetString(Buf, 0, ReadedBufLen);
if rfIgnoreCase in ReplaceFlags then
IsReplaced := ContainsText(BufStr, AFrom)
else
IsReplaced := ContainsStr(BufStr, AFrom);
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
LastIndex := Length(BufStr);
SetLength(BufStr, LastIndex);
FSourceFile.Seek(FEncoding.GetByteCount(BufStr) - ReadedBufLen, soCurrent);
BufStr := StringReplace(BufStr, AFrom, ATo, ReplaceFlags);
DestBytes := FEncoding.GetBytes(BufStr);
FtmpFile.Write(DestBytes, Length(DestBytes));
end;
var
Buf: TBytes;
BufLen: Integer;
bReplaced: Boolean;
begin
FSourceFile.Seek(0, soBeginning);
FtmpFile.Size := 0;
CopyPreamble;
SourceSize := FSourceFile.Size;
BufLen := Max(FEncoding.GetByteCount(AFrom) * 5, 2048);
BufLen := Max(FEncoding.GetByteCount(ATo) * 5, BufLen);
SetLength(Buf, BufLen);
bReplaced := False;
while FSourceFile.Position < SourceSize do
begin
BufLen := FSourceFile.Read(Buf, Length(Buf));
SetLength(Buf, BufLen);
ParseBuffer(Buf, bReplaced);
end;
FSourceFile.Size := 0;
FSourceFile.CopyFrom(FtmpFile, 0);
end;
how to use:
procedure TForm2.btn1Click(Sender: TObject);
var
Replacer: TFileSearchReplace;
StartTime: TDateTime;
begin
StartTime:=Now;
Replacer:=TFileSearchReplace.Create('c:\Temp\123.txt');
try
Replacer.Replace('some текст', 'some', [rfReplaceAll, rfIgnoreCase]);
finally
Replacer.Free;
end;
Caption:=FormatDateTime('nn:ss.zzz', Now - StartTime);
end;
Your first try creates several copies of the file in memory:
it loads the whole file into memory (TStringList)
it creates a copy of this memory when accessing the .Text property
it creates yet another copy of this memory when passing that string to StringReplace (The copy is the result which is built in StringReplace.)
You could try to solve the out of memory problem by getting rid of one or more of these copies:
e.g. read the file into a simple string variable rather than a TStringList
or keep the string list but run the StringReplace on each line separately and write the result to the file line by line.
That would increase the maximum file size your code can handle, but you will still run out of memory for huge files. If you want to handle files of any size, your second approach is the way to go.
No - I don't think there's a faster way that the 2nd option (if you want a completely generic search'n'replace function for any file of any size). It may be possible to make a faster version if you code it specifically according to your requirements, but as a general-purpose search'n'replace function, I don't believe you can go faster...
For instance, are you sure you need case-insensitive replacement? I would expect that this would be a large part of the time spent in the replace function. Try (just for kicks) to remove that requirement and see if it doesn't speed up the execution quite a bit on large files (this depends on how the internal coding of the StringReplace function is made - if it has a specific optimization for case-sensitive searches)
I believe refinement of Kami's code is needed to account for the string not being found, but the start of a new instance of the string might occur at the end of the buffer. The else clause is different:
if IsReplaced then begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end else
LastIndex :=Length(BufStr) - Length(AFrom) + 1;
Correct fix is this one:
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
if FSourceFile.Position < SourceSize then
LastIndex := Length(BufStr) - Length(AFrom) + 1
else
LastIndex := Length(BufStr);

in Delphi7, How can I retrieve hard disk unique serial number?

Hi
I want to retrieve HDD unique (hardware) serial number.
I use some functions but in Windows Seven or Vista they don't work correctly because of admin right.
Is it possible retrieve it without run as Administrator?
Following the links in the question comments Sertac posted, I came across this interesting C++ question, where Fredou answered with a nice link to a codeproject example showing how to do this in .NET, which in turn was based on a link to Borland C++ code and article.
The cool thing is that this C++ code works as a non-administrator user too!
Now you need someone to help you translate this C++ code to Delphi.
Edit: Found a Delphi unit that does this for you.
I wrote some sample use for it:
program DiskDriveSerialConsoleProject;
{$APPTYPE CONSOLE}
uses
Windows,
SysUtils,
hddinfo in 'hddinfo.pas';
const
// Max number of drives assuming primary/secondary, master/slave topology
MAX_IDE_DRIVES = 16;
procedure ReadPhysicalDriveInNTWithZeroRights ();
var
DriveNumber: Byte;
HDDInfo: THDDInfo;
begin
HDDInfo := THDDInfo.Create();
try
for DriveNumber := 0 to MAX_IDE_DRIVES - 1 do
try
HDDInfo.DriveNumber := DriveNumber;
if HDDInfo.IsInfoAvailable then
begin
Writeln('VendorId: ', HDDInfo.VendorId);
Writeln('ProductId: ', HDDInfo.ProductId);
Writeln('ProductRevision: ', HDDInfo.ProductRevision);
Writeln('SerialNumber: ', HDDInfo.SerialNumber);
Writeln('SerialNumberInt: ', HDDInfo.SerialNumberInt);
Writeln('SerialNumberText: ', HDDInfo.SerialNumberText);
end;
except
on E: Exception do
Writeln(Format('DriveNumber %d, %s: %s', [DriveNumber, E.ClassName, E.Message]));
end;
finally
HDDInfo.Free;
end;
end;
begin
ReadPhysicalDriveInNTWithZeroRights;
Write('Press <Enter>');
Readln;
end.
Unit from http://www.delphipraxis.net/564756-post28.html
// http://www.delphipraxis.net/564756-post28.html
unit hddinfo;
interface
uses Windows, SysUtils, Classes;
const
IOCTL_STORAGE_QUERY_PROPERTY = $2D1400;
type
THDDInfo = class (TObject)
private
FDriveNumber: Byte;
FFileHandle: Cardinal;
FInfoAvailable: Boolean;
FProductRevision: string;
FProductId: string;
FSerialNumber: string;
FVendorId: string;
procedure ReadInfo;
procedure SetDriveNumber(const Value: Byte);
public
constructor Create;
property DriveNumber: Byte read FDriveNumber write SetDriveNumber;
property VendorId: string read FVendorId;
property ProductId: string read FProductId;
property ProductRevision: string read FProductRevision;
property SerialNumber: string read FSerialNumber;
function SerialNumberInt: Cardinal;
function SerialNumberText: string;
function IsInfoAvailable: Boolean;
end;
implementation
type
STORAGE_PROPERTY_QUERY = packed record
PropertyId: DWORD;
QueryType: DWORD;
AdditionalParameters: array[0..3] of Byte;
end;
STORAGE_DEVICE_DESCRIPTOR = packed record
Version: ULONG;
Size: ULONG;
DeviceType: Byte;
DeviceTypeModifier: Byte;
RemovableMedia: Boolean;
CommandQueueing: Boolean;
VendorIdOffset: ULONG;
ProductIdOffset: ULONG;
ProductRevisionOffset: ULONG;
SerialNumberOffset: ULONG;
STORAGE_BUS_TYPE: DWORD;
RawPropertiesLength: ULONG;
RawDeviceProperties: array[0..511] of Byte;
end;
function ByteToChar(const B: Byte): Char;
begin
Result := Chr(B + $30)
end;
function SerialNumberToCardinal (SerNum: String): Cardinal;
begin
HexToBin(PChar(SerNum), PChar(#Result), SizeOf(Cardinal));
end;
function SerialNumberToString(SerNum: String): String;
var
I, StrLen: Integer;
Pair: string;
B: Byte;
Ch: Char absolute B;
begin
Result := '';
StrLen := Length(SerNum);
if Odd(StrLen) then Exit;
I := 1;
while I < StrLen do
begin
Pair := Copy (SerNum, I, 2);
HexToBin(PChar(Pair), PChar(#B), 1);
Result := Result + Chr(B);
Inc(I, 2);
end;
I := 1;
while I < Length(Result) do
begin
Ch := Result[I];
Result[I] := Result[I + 1];
Result[I + 1] := Ch;
Inc(I, 2);
end;
end;
constructor THddInfo.Create;
begin
inherited;
SetDriveNumber(0);
end;
function THDDInfo.IsInfoAvailable: Boolean;
begin
Result := FInfoAvailable
end;
procedure THDDInfo.ReadInfo;
type
PCharArray = ^TCharArray;
TCharArray = array[0..32767] of Char;
var
Returned: Cardinal;
Status: LongBool;
PropQuery: STORAGE_PROPERTY_QUERY;
DeviceDescriptor: STORAGE_DEVICE_DESCRIPTOR;
PCh: PChar;
begin
FInfoAvailable := False;
FProductRevision := '';
FProductId := '';
FSerialNumber := '';
FVendorId := '';
try
FFileHandle := CreateFile(
PChar('\\.\PhysicalDrive' + ByteToChar(FDriveNumber)),
0,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil,
OPEN_EXISTING,
0,
0
);
if FFileHandle = INVALID_HANDLE_VALUE then
RaiseLastOSError;
ZeroMemory(#PropQuery, SizeOf(PropQuery));
ZeroMemory(#DeviceDescriptor, SizeOf(DeviceDescriptor));
DeviceDescriptor.Size := SizeOf(DeviceDescriptor);
Status := DeviceIoControl(
FFileHandle,
IOCTL_STORAGE_QUERY_PROPERTY,
#PropQuery,
SizeOf(PropQuery),
#DeviceDescriptor,
DeviceDescriptor.Size,
Returned,
nil
);
if not Status then
RaiseLastOSError;
if DeviceDescriptor.VendorIdOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.VendorIdOffset];
FVendorId := PCh;
end;
if DeviceDescriptor.ProductIdOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.ProductIdOffset];
FProductId := PCh;
end;
if DeviceDescriptor.ProductRevisionOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.ProductRevisionOffset];
FProductRevision := PCh;
end;
if DeviceDescriptor.SerialNumberOffset <> 0 then
begin
PCh := #PCharArray(#DeviceDescriptor)^[DeviceDescriptor.SerialNumberOffset];
FSerialNumber := PCh;
end;
FInfoAvailable := True;
finally
if FFileHandle <> INVALID_HANDLE_VALUE then
CloseHandle(FFileHandle);
end;
end;
function THDDInfo.SerialNumberInt: Cardinal;
begin
Result := 0;
if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToCardinal(FSerialNumber)
end;
function THDDInfo.SerialNumberText: string;
begin
Result := '';
if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToString(FSerialNumber)
end;
procedure THDDInfo.SetDriveNumber(const Value: Byte);
begin
FDriveNumber := Value;
ReadInfo;
end;
end.
Edit: RAID configurations require special provisions.
For instance, I got a RAID system with multiple RAID 5 array; only the first one displays, and it does not show the drive serial numbers, but the serial number of the RAID array:
VendorId: AMCC
ProductId: 9550SXU-16ML
ProductRevision: 3.08
SerialNumber: 006508296D6A2A00DE82
SerialNumberInt: 688416000
--jeroen
You can use the WMI (Windows Management Instrumentation) to get information related to windows hardware.
Exist two wmi classes wich exposes a property called SerialNumber which store the Number allocated by the manufacturer to identify the physical media. these classes are Win32_DiskDrive and Win32_PhysicalMedia.to access the SerialNumber property of these classes you must know the DeviceId of the Disk which is something like this \\.\PHYSICALDRIVE0. Another way is use a association class which link the Physical drive with the logical drive (C,D,E)
so you must find this link previous to obtain the serial number. the sequence to find this association is like this.
Win32_DiskPartition -> Win32_LogicalDiskToPartition -> Win32_DiskDrive
Note 1 : The SerialNumber property for the Win32_DiskDrive class does not exist in Windows Server 2003, Windows XP, Windows 2000, and Windows NT 4.0, so how you are talking about use Windows Vista or Windows 7, will work ok for you.
Note 2 : The code does not require a administrator account to run.
check this code
{$APPTYPE CONSOLE}
uses
SysUtils,
ActiveX,
ComObj,
Variants;
function GetDiskSerial(const Drive:AnsiChar):string;
var
FSWbemLocator : OLEVariant;
objWMIService : OLEVariant;
colDiskDrives : OLEVariant;
colLogicalDisks: OLEVariant;
colPartitions : OLEVariant;
objDiskDrive : OLEVariant;
objPartition : OLEVariant;
objLogicalDisk : OLEVariant;
oEnumDiskDrive : IEnumvariant;
oEnumPartition : IEnumvariant;
oEnumLogical : IEnumvariant;
iValue : LongWord;
DeviceID : string;
begin;
Result:='';
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
objWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', ''); //Connect to the WMI
colDiskDrives := objWMIService.ExecQuery('SELECT * FROM Win32_DiskDrive','WQL',0);
oEnumDiskDrive:= IUnknown(colDiskDrives._NewEnum) as IEnumVariant;
while oEnumDiskDrive.Next(1, objDiskDrive, iValue) = 0 do
begin
DeviceID := StringReplace(objDiskDrive.DeviceID,'\','\\',[rfReplaceAll]); //Escape the `\` chars in the DeviceID value because the '\' is a reserved character in WMI.
colPartitions := objWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskDrive.DeviceID="%s"} WHERE AssocClass = Win32_DiskDriveToDiskPartition',[DeviceID]));//link the Win32_DiskDrive class with the Win32_DiskDriveToDiskPartition class
oEnumPartition := IUnknown(colPartitions._NewEnum) as IEnumVariant;
while oEnumPartition.Next(1, objPartition, iValue) = 0 do
begin
colLogicalDisks := objWMIService.ExecQuery('ASSOCIATORS OF {Win32_DiskPartition.DeviceID="'+objPartition.DeviceID+'"} WHERE AssocClass = Win32_LogicalDiskToPartition'); //link the Win32_DiskPartition class with theWin32_LogicalDiskToPartition class.
oEnumLogical := IUnknown(colLogicalDisks._NewEnum) as IEnumVariant;
while oEnumLogical.Next(1, objLogicalDisk, iValue) = 0 do
begin
if objLogicalDisk.DeviceID=(Drive+':') then //compare the device id
begin
Result:=objDiskDrive.SerialNumber;
Exit;
end;
objLogicalDisk:=Unassigned;
end;
objPartition:=Unassigned;
end;
end;
end;
begin
try
CoInitialize(nil);
try
Writeln(GetDiskSerial('C'));
Readln;
finally
CoUninitialize;
end;
except
on E:Exception do
begin
Writeln(E.Classname, ':', E.Message);
Readln;
end;
end;
end.
Here is another DiskId32 translation from C++ to Delphi by Victor Derevyanko
project:
http://code.google.com/p/dvsrc/
Because the first method (WithZeroRights) doesn't work for me, I wrote another for ReadIdeDriveAsScsiDriveInNT method:
unit HDScsiInfo;
interface
uses
Windows, SysUtils;
const
IDENTIFY_BUFFER_SIZE = 512;
FILE_DEVICE_SCSI = $0000001b;
IOCTL_SCSI_MINIPORT_IDENTIFY = ((FILE_DEVICE_SCSI shl 16) + $0501);
IDE_ATA_IDENTIFY = $EC; // Returns ID sector for ATA.
IOCTL_SCSI_MINIPORT = $0004D008; // see NTDDSCSI.H for definition
type
TDiskData = array [0..256-1] of DWORD;
TDriveInfo = record
ControllerType: Integer; //0 - primary, 1 - secondary, 2 - Tertiary, 3 - Quaternary
DriveMS: Integer; //0 - master, 1 - slave
DriveModelNumber: String;
DriveSerialNumber: String;
DriveControllerRevisionNumber: String;
ControllerBufferSizeOnDrive: Int64;
DriveType: String; //fixed or removable or unknown
DriveSizeBytes: Int64;
end;
THDScsiInfo = class (TObject)
private
FDriveNumber: Byte;
FFileHandle: Cardinal;
FInfoAvailable: Boolean;
FProductRevision: string;
FSerialNumber: string;
FControllerType: Integer;
FDriveMS: Integer;
FDriveModelNumber: string;
FControllerBufferSizeOnDrive: Int64;
FDriveType: string;
FDriveSizeBytes: Int64;
procedure ReadInfo;
procedure SetDriveNumber(const Value: Byte);
procedure PrintIdeInfo(DiskData: TDiskData);
public
constructor Create;
property DriveNumber: Byte read FDriveNumber write SetDriveNumber;
property ProductRevision: string read FProductRevision;
property SerialNumber: string read FSerialNumber;
property ControllerType: Integer read FControllerType;
property DriveMS: Integer read FDriveMS;
property DriveModelNumber: string read FDriveModelNumber;
property ControllerBufferSizeOnDrive: Int64 read FControllerBufferSizeOnDrive;
property DriveType: string read FDriveType;
property DriveSizeBytes: Int64 read FDriveSizeBytes;
function IsInfoAvailable: Boolean;
end;
implementation
type
SRB_IO_CONTROL = record
HeaderLength: Cardinal;
Signature: array [0..8-1] of Byte;
Timeout: Cardinal;
ControlCode: Cardinal;
ReturnCode: Cardinal;
Length: Cardinal;
end;
PSRB_IO_CONTROL = ^SRB_IO_CONTROL;
DRIVERSTATUS = record
bDriverError: Byte;// Error code from driver, or 0 if no error.
bIDEStatus: Byte;// Contents of IDE Error register.
// Only valid when bDriverError is SMART_IDE_ERROR.
bReserved: array [0..1] of Byte;// Reserved for future expansion.
dwReserved: array [0..1] of Longword;// Reserved for future expansion.
end;
SENDCMDOUTPARAMS = record
cBufferSize: Longword;// Size of bBuffer in bytes
DriverStatus: DRIVERSTATUS;// Driver status structure.
bBuffer: array [0..0] of Byte;// Buffer of arbitrary length in which to store the data read from the // drive.
end;
IDEREGS = record
bFeaturesReg: Byte;// Used for specifying SMART "commands".
bSectorCountReg: Byte;// IDE sector count register
bSectorNumberReg: Byte;// IDE sector number register
bCylLowReg: Byte;// IDE low order cylinder value
bCylHighReg: Byte;// IDE high order cylinder value
bDriveHeadReg: Byte;// IDE drive/head register
bCommandReg: Byte;// Actual IDE command.
bReserved: Byte;// reserved for future use. Must be zero.
end;
SENDCMDINPARAMS = record
cBufferSize: Longword;// Buffer size in bytes
irDriveRegs: IDEREGS; // Structure with drive register values.
bDriveNumber: Byte;// Physical drive number to send
// command to (0,1,2,3).
bReserved: array[0..2] of Byte;// Reserved for future expansion.
dwReserved: array [0..3] of Longword;// For future use.
bBuffer: array [0..0] of Byte;// Input buffer. //!TODO: this is array of single element
end;
PSENDCMDINPARAMS = ^SENDCMDINPARAMS;
PSENDCMDOUTPARAMS = ^SENDCMDOUTPARAMS;
IDSECTOR = record
wGenConfig: Word;
wNumCyls: Word;
wReserved: Word;
wNumHeads: Word;
wBytesPerTrack: Word;
wBytesPerSector: Word;
wSectorsPerTrack: Word;
wVendorUnique: array [0..3-1] of Word;
sSerialNumber: array [0..20-1] of AnsiChar;
wBufferType: Word;
wBufferSize: Word;
wECCSize: Word;
sFirmwareRev: array [0..8-1] of AnsiChar;
sModelNumber: array [0..40-1] of AnsiChar;
wMoreVendorUnique: Word;
wDoubleWordIO: Word;
wCapabilities: Word;
wReserved1: Word;
wPIOTiming: Word;
wDMATiming: Word;
wBS: Word;
wNumCurrentCyls: Word;
wNumCurrentHeads: Word;
wNumCurrentSectorsPerTrack: Word;
ulCurrentSectorCapacity: Cardinal;
wMultSectorStuff: Word;
ulTotalAddressableSectors: Cardinal;
wSingleWordDMA: Word;
wMultiWordDMA: Word;
bReserved: array [0..128-1] of Byte;
end;
PIDSECTOR = ^IDSECTOR;
TArrayDriveInfo = array of TDriveInfo;
type
DeviceQuery = record
HeaderLength: Cardinal;
Signature: array [0..8-1] of Byte;
Timeout: Cardinal;
ControlCode: Cardinal;
ReturnCode: Cardinal;
Length: Cardinal;
cBufferSize: Longword;// Buffer size in bytes
irDriveRegs: IDEREGS; // Structure with drive register values.
bDriveNumber: Byte;// Physical drive number to send
bReserved: array[0..2] of Byte;// Reserved for future expansion.
dwReserved: array [0..3] of Longword;// For future use.
bBuffer: array [0..0] of Byte;// Input buffer. //!TODO: this is array of single element
end;
function ConvertToString (diskdata: TDiskData;
firstIndex: Integer;
lastIndex: Integer;
buf: PAnsiChar): PAnsiChar;
var
index: Integer;
position: Integer;
begin
position := 0;
// each integer has two characters stored in it backwards
for index := firstIndex to lastIndex do begin
// get high byte for 1st character
buf[position] := AnsiChar(Chr(diskdata [index] div 256));
inc(position);
// get low byte for 2nd character
buf [position] := AnsiChar(Chr(diskdata [index] mod 256));
inc(position);
end;
// end the string
buf[position] := Chr(0);
// cut off the trailing blanks
index := position - 1;
while (index >0) do begin
// if not IsSpace(AnsiChar(buf[index]))
if (AnsiChar(buf[index]) <> ' ')
then break;
buf [index] := Chr(0);
dec(index);
end;
Result := buf;
end;
constructor THDScsiInfo.Create;
begin
inherited;
SetDriveNumber(0);
end;
function THDScsiInfo.IsInfoAvailable: Boolean;
begin
Result := FInfoAvailable
end;
procedure THDScsiInfo.PrintIdeInfo (DiskData: TDiskData);
var
nSectors: Int64;
serialNumber: array [0..1024-1] of AnsiChar;
modelNumber: array [0..1024-1] of AnsiChar;
revisionNumber: array [0..1024-1] of AnsiChar;
begin
// copy the hard drive serial number to the buffer
ConvertToString (DiskData, 10, 19, #serialNumber);
ConvertToString (DiskData, 27, 46, #modelNumber);
ConvertToString (DiskData, 23, 26, #revisionNumber);
FControllerType := FDriveNumber div 2;
FDriveMS := FDriveNumber mod 2;
FDriveModelNumber := modelNumber;
FSerialNumber := serialNumber;
FProductRevision := revisionNumber;
FControllerBufferSizeOnDrive := DiskData [21] * 512;
if ((DiskData [0] and $0080) <> 0)
then FDriveType := 'Removable'
else if ((DiskData [0] and $0040) <> 0)
then FDriveType := 'Fixed'
else FDriveType := 'Unknown';
// calculate size based on 28 bit or 48 bit addressing
// 48 bit addressing is reflected by bit 10 of word 83
if ((DiskData[83] and $400) <> 0) then begin
nSectors := DiskData[103] * Int64(65536) * Int64(65536) * Int64(65536) +
DiskData[102] * Int64(65536) * Int64(65536) +
DiskData[101] * Int64(65536) +
DiskData[100];
end else begin
nSectors := DiskData [61] * 65536 + DiskData [60];
end;
// there are 512 bytes in a sector
FDriveSizeBytes := nSectors * 512;
end;
procedure THDScsiInfo.ReadInfo;
type
DataArry = array [0..256-1] of WORD;
PDataArray = ^DataArry;
const
SENDIDLENGTH = sizeof (SENDCMDOUTPARAMS) + IDENTIFY_BUFFER_SIZE;
var
I: Integer;
buffer: array [0..sizeof (SRB_IO_CONTROL) + SENDIDLENGTH - 1] of AnsiChar;
dQuery: DeviceQuery;
dummy: DWORD;
pOut: PSENDCMDOUTPARAMS;
pId: PIDSECTOR;
DiskData: TDiskData;
pIdSectorPtr: PWord;
begin
FInfoAvailable := False;
FFileHandle := CreateFile (PChar(Format('\\.\Scsi%d:', [FDriveNumber])),
GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil,
OPEN_EXISTING, 0, 0);
if (FFileHandle <> INVALID_HANDLE_VALUE) then begin
ZeroMemory(#dQuery, SizeOf(dQuery));
dQuery.HeaderLength := sizeof (SRB_IO_CONTROL);
dQuery.Timeout := 10000;
dQuery.Length := SENDIDLENGTH;
dQuery.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
StrLCopy(#dQuery.Signature, 'SCSIDISK', 8);
dQuery.irDriveRegs.bCommandReg := IDE_ATA_IDENTIFY;
dQuery.bDriveNumber := FDriveNumber;
if (DeviceIoControl (FFileHandle, IOCTL_SCSI_MINIPORT,
#dQuery,
SizeOf(dQuery),
#buffer,
sizeof (SRB_IO_CONTROL) + SENDIDLENGTH,
dummy, nil))
then begin
pOut := PSENDCMDOUTPARAMS(buffer + sizeof (SRB_IO_CONTROL)); //!TOCHECK
pId := PIDSECTOR(#pOut^.bBuffer[0]);
if (pId^.sModelNumber[0] <> Chr(0) ) then begin
pIdSectorPtr := PWord(pId);
for I := 0 to 256-1 do
DiskData[I] := PDataArray(pIdSectorPtr)[I];
PrintIdeInfo (DiskData);
FInfoAvailable := True;
end;
end;
CloseHandle(FFileHandle);
end;
end;
procedure THDScsiInfo.SetDriveNumber(const Value: Byte);
begin
FDriveNumber := Value;
ReadInfo;
end;
end.
Sample usage:
procedure ReadIdeDriveAsScsiDriveInNT;
var
DriveNumber: Byte;
HDDInfo: THDScsiInfo;
begin
HDDInfo := THDScsiInfo.Create();
try
for DriveNumber := 0 to MAX_IDE_DRIVES - 1 do
try
HDDInfo.DriveNumber := DriveNumber;
if HDDInfo.IsInfoAvailable then begin
Writeln('Available Drive: ', HDDInfo.DriveNumber);
Writeln('ControllerType: ', HDDInfo.ControllerType);
Writeln('DriveMS: ', HDDInfo.DriveMS);
Writeln('DriveModelNumber: ', HDDInfo.DriveModelNumber);
Writeln('ControllerBufferSizeOnDrive: ', HDDInfo.ControllerBufferSizeOnDrive);
Writeln('DriveType: ', HDDInfo.DriveType);
Writeln('DriveSizeBytes: ', HDDInfo.DriveSizeBytes);
Writeln('ProductRevision: ', HDDInfo.ProductRevision);
Writeln('SerialNumber: ', HDDInfo.SerialNumber);
end;
except
on E: Exception do
Writeln(Format('DriveNumber %d, %s: %s', [DriveNumber, E.ClassName, E.Message]));
end;
finally
HDDInfo.Free;
end;
end;
begin
ReadIdeDriveAsScsiDriveInNT;
Write('Press <Enter>');
end.
This works great with my WD disk.
I found this code, it is fixed one and working fine with me on windows 7 64
https://code.google.com/p/dvsrc/downloads/detail?name=20120116DiskId32Port_fixed.7z&can=2&q=
and this his all work
https://code.google.com/p/dvsrc/downloads/list
Posting this purely for completeness sake, and to possibly satisfy those interested or die hard hardware fanatics.
I do not have a Pascal compiler at my disposal to test these routines on current Windows systems, but I do know this code worked back in the DOS era. Maybe it still works from a command prompt window.
Pascal code:
uses
Dos, Crt;
type
SerNoType = record
case Integer of
0: (SerNo1, SerNo2: Word);
1: (SerNo: Longint);
end;
DiskSerNoInfoType = record
Infolevel: Word;
VolSerNo: SerNoType;
VolLabel: array[1..11] of Char;
FileSys: array[1..8] of Char;
end;
function HexDigit(N: Byte): Char;
begin
if N < 10 then
HexDigit := Chr(Ord('0') + N)
else
HexDigit := Chr(Ord('A') + (N - 10));
end;
function GetVolSerialNo(DriveNo: Byte): String;
var
ReturnArray: DiskSerNoInfoType;
Regs: Registers;
begin
with Regs do
begin
AX := $440d;
BL := DriveNo;
CH := $08;
CL := $66;
DS := Seg(ReturnArray);
DX := Ofs(ReturnArray);
Intr($21, Regs);
if (Flags and FCarry) <> 0 then
GetVolSerialNo := ''
else
with ReturnArray.VolSerNo do
GetVolSerialNo :=
HexDigit(Hi(SerNo2) div 16) + HexDigit(Hi(SerNo2) mod 16) +
HexDigit(Lo(SerNo2) div 16) + HexDigit(Lo(SerNo2) mod 16) +
HexDigit(Hi(SerNo1) div 16) + HexDigit(Hi(SerNo1) mod 16) +
HexDigit(Lo(SerNo1) div 16) + HexDigit(Lo(SerNo1) mod 16);
end;
end;
procedure PutVolSerialNo(DriveNo: Byte; SerialNo: Longint);
var
ReturnArray: DiskSerNoInfoType;
Regs: Registers;
begin
with Regs do
begin
AX := $440d;
BL := DriveNo;
CH := $08;
CL := $66;
DS := Seg(ReturnArray);
DX := Ofs(ReturnArray);
Intr($21, Regs);
if (Flags and FCarry) = 0 then
begin
ReturnArray.VolSerNo.SerNo := SerialNo;
AH := $69;
BL := DriveNo;
AL := $01;
DS := Seg(ReturnArray);
DX := Ofs(ReturnArray);
Intr($21, Regs);
end;
end;
end;
Please feel free to update this answer in order to get it working (if possible at all) in Delphi.

what is the simpliest way to play sound from array data in delphi

Is there any simple function? I am searching something like that
Play(#data, 44000, 100 {time});
I have worked quite a lot with PCM audio manipulation. I always use this function when playing short sequences of custom waveform audio data:
var
PlaySoundStopper: PBoolean;
SoundPlayerActive: boolean = false;
procedure PlaySound(const Sound: TASSound);
var
hWave: HWAVEOUT;
hdr: TWaveHdr;
buf: PAnsiChar;
fmt: TWaveFormatEx;
i: Integer;
n: Integer;
begin
try
with fmt do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := length(Sound.Channels);
nSamplesPerSec := Sound.SampleRate;
wBitsPerSample := 32;
nAvgBytesPerSec := nChannels * nSamplesPerSec * wBitsPerSample div 8;
nBlockAlign := nChannels * wBitsPerSample div 8;
cbSize := 0;
end;
GetMem(buf, fmt.nChannels * length(Sound.Channels[0]) * sizeof(TASWaveformSample));
if length(Sound.Channels) = 1 then
CopyMemory(buf, #(Sound.Channels[0, 0]), length(Sound.Channels[0]) * sizeof(TASWaveformSample))
else
for i := 0 to high(Sound.Channels[0]) do
for n := 0 to high(Sound.Channels) do
CopyMemory(buf + sizeof(TASWaveformSample) * (i * fmt.nChannels + n), #(Sound.Channels[n, i]), sizeof(TASWaveformSample));
if waveOutOpen(#hWave, WAVE_MAPPER, #fmt, 0, 0, CALLBACK_NULL) <> MMSYSERR_NOERROR then
raise Exception.Create('SoundPlayerThread.Execute: waveOutOpen failed: ' + SysErrorMessage(GetLastError));
ZeroMemory(#hdr, sizeof(hdr));
with hdr do
begin
lpData := buf;
dwBufferLength := fmt.nChannels * length(Sound.Channels[0]) * sizeof(TASWaveformSample);
dwFlags := 0;
end;
try
SoundPlayerActive := true;
waveOutPrepareHeader(hWave, #hdr, sizeof(hdr));
waveOutWrite(hWave, #hdr, sizeof(hdr));
sleep(500);
while waveOutUnprepareHeader(hWave, #hdr, sizeof(hdr)) = WAVERR_STILLPLAYING do
if PlaySoundStopper^ then
begin
waveOutPause(hWave);
waveOutUnprepareHeader(hWave, #hdr, sizeof(hdr));
break;
end
else
sleep(100);
finally
SoundPlayerActive := false;
waveOutClose(hWave);
FreeMem(buf);
end;
except
on E: Exception do MessageBox(0, PChar(E.ClassName + ': ' + E.Message), 'Sound Playback Error', MB_ICONERROR);
end;
end;
where
type
TASWaveformSample = integer; // signed 32-bit; -2147483648..2147483647
TASWaveformSamples = packed array of TASWaveformSample; // one channel
PASSound = ^TASSound;
TASSound = record
Channels: packed array of TASWaveformSamples;
SampleRate: cardinal;
end;
A perhaps better way, is to use a thread for the playing. Then I do
var
OwnerForm: HWND; // = 0;
SndSource: PASSound; // = nil;
ThreadPlaying: boolean; // = false;
type
TSoundPlayerThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
implemented as
procedure TSoundPlayerThread.Execute;
var
hWave: HWAVEOUT;
hdr: TWaveHdr;
buf: PAnsiChar;
fmt: TWaveFormatEx;
i: Integer;
n: Integer;
begin
ThreadPlaying := true;
try
try
if not Assigned(SndSource) then
Exit;
with fmt do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := length(SndSource^.Channels);
nSamplesPerSec := SndSource^.SampleRate;
wBitsPerSample := 32;
nAvgBytesPerSec := nChannels * nSamplesPerSec * wBitsPerSample div 8;
nBlockAlign := nChannels * wBitsPerSample div 8;
cbSize := 0;
end;
GetMem(buf, fmt.nChannels * length(SndSource^.Channels[0]) * sizeof(TASWaveformSample));
if length(SndSource^.Channels) = 1 then
CopyMemory(buf, #(SndSource^.Channels[0, 0]), length(SndSource^.Channels[0]) * sizeof(TASWaveformSample))
else
for i := 0 to high(SndSource^.Channels[0]) do
for n := 0 to high(SndSource^.Channels) do
CopyMemory(buf + sizeof(TASWaveformSample) * (i * fmt.nChannels + n), #(SndSource^.Channels[n, i]), sizeof(TASWaveformSample));
if waveOutOpen(#hWave, WAVE_MAPPER, #fmt, 0, 0, CALLBACK_NULL) <> MMSYSERR_NOERROR then
raise Exception.Create('SoundPlayerThread.Execute: waveOutOpen failed: ' + SysErrorMessage(GetLastError));
ZeroMemory(#hdr, sizeof(hdr));
with hdr do
begin
lpData := buf;
dwBufferLength := fmt.nChannels * length(SndSource^.Channels[0]) * sizeof(TASWaveformSample);
dwFlags := 0;
end;
waveOutPrepareHeader(hWave, #hdr, sizeof(hdr));
waveOutWrite(hWave, #hdr, sizeof(hdr));
sleep(500);
while waveOutUnprepareHeader(hWave, #hdr, sizeof(hdr)) = WAVERR_STILLPLAYING do
begin
sleep(100);
if Terminated then
waveOutReset(hWave);
end;
waveOutClose(hWave);
FreeMem(buf);
except
on E: Exception do MessageBox(0, PChar(E.ClassName + ': ' + E.Message), 'TSoundPlayerThread', MB_ICONERROR);
end;
finally
ThreadPlaying := false;
end;
end;
Wave Audio Package has TLiveAudioPlayer component. It plays audio from buffer.
The Win32 API PlaySound function can play standard RIFF-encoded audio (such as WAV audio) from a memory block by using its SND_MEMORY flag. Alternatively, if the audio is in the app's resources, you can use the SND_RESOURCE flag instead.
Microsoft has a Knowledge Base article telling you how you can play sound from memory using MCI. You'll probably need to have the wave file header in your array, or otherwise copy in the right data during the first read, but other than that it should be fairly easy to port over.
I couldn't find a complete solution that isn't based on the outdated sndPlaySound, so here are two functions that play ".wav" files from both a TMemoryStream and from a file :
uses mmsystem;
procedure PlaySoundFromFile(FileName : String);
var
mStream : TMemoryStream;
begin
mStream := TMemoryStream.Create;
Try mStream.LoadFromFile(FileName); Except End;
If mStream.Size > 0 then PlaySoundFromStream(mStream);
mStream.Free;
end;
procedure PlaySoundFromStream(mStream : TMemoryStream);
begin
PlaySound(mStream.Memory,0,SND_MEMORY or SND_SYNC);
end;
The sound is played synchronously and from memory, you can find the other PlaySound flags in the link on Remy's answer. If you switch to async playback, make sure to not clear the sound memory before playback ends.

Resources