مجموعة من أكواد التعامل مع الصوتيات

[issamdnn]

أقدم لكم هذه المجموعة من الأكواد للمهتمين بموضوع الميديا (برمجة برامج الصوتيات) وقد قمت بجمعها من مجموعة من المواقع فهي ليست مني بل هي منقولة ولكني قمت بجمعها لأعضاء المنتدى :

كود كتم الصوت الخاص بكرت الصوت الخاص بالجهاز:

uses
MMSystem;

function GetMasterMute(
Mixer: hMixerObj;
var Control: TMixerControl): MMResult;
// Returns True on success
var
Line: TMixerLine;
Controls: TMixerLineControls;
begin
ZeroMemory(@Line, SizeOf(Line));
Line.cbStruct := SizeOf(Line);
Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
Result := mixerGetLineInfo(Mixer, @Line,
MIXER_GETLINEINFOF_COMPONENTTYPE);
if Result = MMSYSERR_NOERROR then
begin
ZeroMemory(@Controls, SizeOf(Controls));
Controls.cbStruct := SizeOf(Controls);
Controls.dwLineID := Line.dwLineID;
Controls.cControls := 1;
Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
Controls.cbmxctrl := SizeOf(Control);
Controls.pamxctrl := @Control;
Result := mixerGetLineControls(Mixer, @Controls,
MIXER_GETLINECONTROLSF_ONEBYTYPE);
end;
end;

procedure SetMasterMuteValue(
Mixer: hMixerObj;
Value: Boolean);
var
MasterMute: TMixerControl;
Details: TMixerControlDetails;
BoolDetails: TMixerControlDetailsBoolean;
Code: MMResult;
begin
Code := GetMasterMute(0, MasterMute);
if Code = MMSYSERR_NOERROR then
begin
with Details do
begin
cbStruct := SizeOf(Details);
dwControlID := MasterMute.dwControlID;
cChannels := 1;
cMultipleItems := 0;
cbDetails := SizeOf(BoolDetails);
paDetails := @BoolDetails;
end;
LongBool(BoolDetails.fValue) := Value;
Code := mixerSetControlDetails(0, @Details,
MIXER_SETCONTROLDETAILSF_VALUE);
end;
if Code <> MMSYSERR_NOERROR then
raise Exception.CreateFmt('SetMasterMuteValue failure, '+
'multimedia system error #%d', [Code]);
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off
end;


تفعيل أو إلغاء تفعيل خاصية ال AutoPlay الخاصة بال CD :

uses
Registry;

procedure CDSetAutoPlay(SioNo: Boolean);
var
Reg: TRegistry;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.KeyExists('Software\Classes\AudioCD\') then
if Reg.OpenKey('Software\Classes\AudioCD\Shell\', False) then
if SioNo then Reg.WriteString('', 'play')
else
Reg.WriteString('', '');
finally
Reg.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{Activate AutoPlay}
CDSetAutoPlay(True);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Deactivate Autoplay}
CDSetAutoPlay(False);
end;



ضبط حجم الصوت في الأجهزة :



uses
MMSystem;

function GetLineInHandle(AudioType: Integer): Integer;
var
i: Integer;
AudioCaps: TAuxCaps;
begin
Result := 0;
for i := 0 to auxGetNumDevs - 1 do
begin
auxGetDevCaps(i, @AudioCaps, SizeOf(AudioCaps));
if AudioCaps.wTechnology = AudioType then
begin
Result := i;
Break;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
v: DWORD;
begin
AuxGetVolume(GetLineInHandle(AUXCAPS_CDAUDIO), @v);
Edit1.Text := IntToStr(LoWord(v));
Edit2.Text := IntToStr(HiWord(v));
end;

procedure TForm1.Button2Click(Sender: TObject);
var
v: DWORD;
begin
v := MakeLong(Word(StrToInt(Edit1.Text)),
Word(StrToInt(Edit2.Text)));
AuxSetVolume(GetLineInHandle(AUXCAPS_CDAUDIO), v);
end;

procedure TForm1.Button3Click(Sender: TObject);
var
v: DWORD;
begin
AuxGetVolume(GetLineInHandle(AUXCAPS_AUXIN), @v);
Edit3.Text := IntToStr(LoWord(v));
Edit4.Text := IntToStr(HiWord(v));
end;

procedure TForm1.Button4Click(Sender: TObject);
var
v: DWORD;
begin
v := MakeLong(Word(StrToInt(Edit3.Text)),
Word(StrToInt(Edit4.Text)));
AuxSetVolume(GetLineInHandle(AUXCAPS_AUXIN), v);
end;


تغيير حجم صوت كرت الصوت:

uses
MMSystem;

procedure SetVolume(const volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
vol := volL + volR shl 16;
// set volume
waveOutSetVolume(hWO, vol);
waveOutClose(hWO);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
SetVolume(14000, 14000);
end;


{************************************************}

{2.}

{by Serhiy Perevoznyk}

uses
MMSystem;


function GetVolumeControl(aMixer: HMixer; componentType, ctrlType: Longint;
var mxc: TMixerControl): Boolean;
var
mxl: TMixerLine;
mxlc: TMixerLineControls;
rc: Longint;
begin
Result := False;
FillChar(mxl, SizeOf(TMixerLine), 0);
mxl.cbStruct := SizeOf(TMixerLine);
mxl.dwComponentType := componentType;
{Obtain a line corresponding to the component type}
rc := mixerGetLineInfo(aMixer, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);
if rc = MMSYSERR_NOERROR then
begin
with mxlc do
begin
cbStruct := SizeOf(TMixerLineControls);
dwLineID := mxl.dwLineID;
dwControlType := ctrlType;
cControls := 1;
cbmxctrl := SizeOf(TMixerLine);
pamxctrl := @mxc;
pamxctrl^.cbStruct := SizeOf(TMixerControl);
end;
mixerGetLineControls(aMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
rc := mixerGetLineControls(aMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
Result := rc = MMSYSERR_NOERROR;
end;
end;

function SetVolumeControl(aMixer: HMixer; mxc: TMixerControl; volume: Longint): Boolean;
var
mxcd: TMixerControlDetails;
vol: TMixerControlDetails_Unsigned;
rc: MMRESULT;
begin
FillChar(mxcd, SizeOf(mxcd), 0);
with mxcd do
begin
cbStruct := SizeOf(TMixerControlDetails);
dwControlID := mxc.dwControlID;
cbDetails := SizeOf(TMixerControlDetails_Unsigned);
paDetails := @vol;
cMultipleItems := 0;
cChannels := 1;
end;
vol.dwValue := volume;
rc := mixerSetControlDetails(aMixer, @mxcd, MIXER_SETCONTROLDETAILSF_VALUE);
Result := rc = MMSYSERR_NOERROR;
end;

function InitMixer: HMixer;
var
Err: MMRESULT;
begin
Err := mixerOpen(@Result, 0, 0, 0, 0);
if Err <> MMSYSERR_NOERROR then
Result := 0;
end;

// Example:


procedure SetMasterVolumeToZero;
var
MyMixerHandle: HMixer;
MyVolCtrl: TMixerControl;
begin
MyMixerHandle := InitMixer;
if MyMixerHandle <> 0 then
try
FillChar(MyVolCtrl, SizeOf(MyVolCtrl), 0);
if GetVolumeControl(MyMixerHandle, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS,
MIXERCONTROL_CONTROLTYPE_VOLUME, MyVolCtrl) then
begin
{The last parameter (0) here is the volume level}
if SetVolumeControl(MyMixerHandle, MyVolCtrl, 0) then
ShowMessage('Volume should now be set to zero');
end;
finally
mixerClose(MyMixerHandle);
end;
end;


procedure TForm1.Button2Click(Sender: TObject);
begin
SetMasterVolumeToZero
end;



فحص إذا كان كرت الصوت موجود على الجهاز :



uses
MMSystem;

function SoundCardAvailable: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;



فحص إذا كان ال audio-cd موجود ضمن السواقة الليزرية :



function IsAudioCD(Drive: Char): Boolean;
var
DrivePath: string;
MaximumComponentLength: DWORD;
FileSystemFlags: DWORD;
VolumeName: string;
OldErrorMode: UINT;
DriveType: UINT;
begin
Result := False;
DrivePath := Drive + ':\';
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
DriveType := GetDriveType(PChar(DrivePath));
finally
SetErrorMode(OldErrorMode);
end;
if DriveType <> DRIVE_CDROM then
Exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),
PChar(VolumeName),
Length(VolumeName),
nil,
MaximumComponentLength,
FileSystemFlags,
nil,
0);
if lStrCmp(PChar(VolumeName), 'Audio-CD') = 0 then Result := True;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
if IsAudioCD('D') then
ShowMessage('Audio-CD found in drive D.')
else
ShowMessage('No Audio-CD found in drive D.');
end

تحويل ملفات ال SWF إلى EXE


function Swf2Exe(S, D, F: string): string;
//S = Source file (swf)
//D = Destionation file (exe)
//F = Flash Player
var
SourceStream, DestinyStream, LinkStream: TFileStream;
flag: Cardinal;
SwfFileSize: Integer;
begin
Result := 'something error';
DestinyStream := TFileStream.Create(D, fmCreate);
try
LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(LinkStream, 0);
finally
LinkStream.Free;
end;

SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(SourceStream, 0);
flag := $FA123456;
DestinyStream.WriteBuffer(flag, SizeOf(Integer));
SwfFileSize := SourceStream.Size;
DestinyStream.WriteBuffer(SwfFileSize, SizeOf(Integer));
Result := '';
finally
SourceStream.Free;
end;
finally
DestinyStream.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Swf2Exe('c:\somefile.swf', 'c:\somefile.exe',
'c:\Program Files\Macromedia\Flash MX\Players\SAFlashPlayer.exe');
end;


هذه هي المجموعة الأولى والمجوعة القادمة قريباً إنشاء الله .مع التحيات للجميع .

[issamdnn]

ها نحن نعود من جديد مع المجموعة الثانية من اكواد التعامل مع الصوتيات وإليكم الأكواد:

فحص فيما إذا كان TMediaPlayer قد توقف عن تشغيل الصوت
procedure TForm1.FormCreate(Sender: TObject);
begin
MediaPlayer1.Notify := True;
MediaPlayer1.OnNotify := NotifyProc;
end;

procedure TForm1.NotifyProc(Sender: TObject);
begin
with Sender as TMediaPlayer do
begin
case Mode of
mpStopped: {do something here};
end;
//must set to true to enable next-time notification
Notify := True;
end;
end;


تحديد عرض المجال أو ال bitrate لملف ال WAV

{....}

private
procedure OpenMedia(WaveFile : string);
function GetStatus(StatusRequested : DWord) : longint;
procedure CloseMedia;

{....}

var
MyError, dwFlags: Longint;
FDeviceID : Word;

{....}

uses
MMSystem;

{....}

procedure TForm1.OpenMedia(WaveFile: string);
var
MyOpenParms: TMCI_Open_Parms;
begin
with MyOpenParms do
begin
dwCallback := Handle; // TForm1.Handle
lpstrDeviceType := PChar('WaveAudio');
lpstrElementName := PChar(WaveFile);
end; {with MyOpenParms}
dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;
MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));
// one could use mciSendCommand(DevId, here to specify a particular device
if MyError = 0 then
FDeviceID := MyOpenParms.wDeviceID
else
raise Exception.Create('Open Failed');
end;

function TForm1.GetStatus(StatusRequested: DWORD): Longint;
var
MyStatusParms: TMCI_Status_Parms;
begin
dwFlags := MCI_WAIT or MCI_STATUS_ITEM;
with MyStatusParms do
begin
dwCallback := Handle;
dwItem := StatusRequested;
end;
MyError := mciSendCommand(FDeviceID,
MCI_STATUS,
MCI_WAIT or MCI_STATUS_ITEM,
Longint(@MyStatusParms));
if MyError = 0 then
Result := MyStatusParms.dwReturn
else
raise Exception.Create('Status call to get status of ' +
IntToStr(StatusRequested) + ' Failed');
end;

procedure TForm1.CloseMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID > 0 then
begin
dwFlags := 0;
MyGenParms.dwCallback := Handle; // TForm1.Handle
MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags, Longint(@MyGenParms));
if MyError = 0 then
FDeviceID := 0
else
begin
raise Exception.Create('Close Failed');
end;
end;
end;


//Example:
//Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
OpenMedia(OpenDialog1.FileName);
with ListBox1.Items do
begin
Add('Average Bytes / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC) ));
Add('Bits / Sample : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_BITSPERSAMPLE)) );
Add('Samples / Sec : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_SAMPLESPERSEC)) );
Add('Channels : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_CHANNELS)));
end;
CloseMedia;
end;
end;


فحص فيما إذا كان Macromedia Flash plugin منصب أو موجود على النظام:


uses
Forms, Windows, INIFiles, SysUtils, Dialogs, ShellApi;

{$R *.RES}

type
TVersionInfo = record
dwSignature,
dwStrucVersion,
dwFileVersionMS,
dwFileVersionLS,
dwProductVersionMS,
dwProductVersionLS,
dwFileFlagsMask,
dwFileFlags,
dwFileOS,
dwFileType,
dwFileSubtype,
dwFileDateMS,
dwFileDateLS: DWORD;
end;


var
//Reg:TRegistry;
Ini: TIniFile;
Text: array[1..4] of string;

AppPath, IniFile, MySec: string;
SetupFile, RunFile, SetupClass: string;

VersionStr, BrowserStr: string;

{RegSubKey,} OpenBrowser, PlugInName, UseExt: string;
MainVersion: Word;
// FoundOne :Boolean;

PVer, DPchar, POpenBrowser: PChar;
MyPoint: Pointer;
PLen: Cardinal;
version: ^TVersionInfo;
DumD: DWORD;
LWord, HWord: Word;

CheckHandle: Hwnd;

//---------------------------
//Gets the Plugin (file-) Version
//---------------------------
procedure GetVersion(pluginName: string);
begin
DPChar := StrAlloc(255);
DPchar := PChar(PluginName);

PVer := StrAlloc(getFileVersionInfoSize(DPchar, Plen));
getFileVersionInfo(DPChar, 0, 255, PVer);
VerQueryValue(Pver, '\', MyPoint, Plen);

Version := myPoint;

dumD := Version.dwFileVersionMS;
hword := dumD shr 16;
lword := dumD and 255;

MainVersion := hword;
VersionStr := IntToStr(Hword) + '.' + IntToStr(LWord);

dumD := Version.dwFileVersionLs;
hword := dumD shr 16;
lword := dumD and 255;

versionStr := versionStr + '.' + IntToStr(Hword) + '.' + IntToStr(lWord);
end;

begin
appPath := extractFileDir(Application.exeName);


// runFile:= 'test.htm';
//runFile must be a html File to determin wich browser(NC or IE) is used
POpenBrowser := StrAlloc(255);
FindExecutable(PChar(extractFileName(runFile)),
PChar(extractFileDir(runFile)), POpenBrowser);
OpenBrowser := POpenBrowser;

if not Fileexists(openBrowser) then
begin
MessageDlg(Text[4], mtInformation, [mbOK], 0);
halt;
end;


//set the FileLocations for Netscape or IE
if Pos('NETSCAPE.EXE', uppercase(trim(OpenBrowser))) <> 0 then
begin //found Netscape
BrowserStr := 'Netscape Comunicator';
PlugInName := Copy(OpenBrowser, 1, Pos('NETSCAPE.EXE',
uppercase(trim(OpenBrowser))) - 1);
PluginName := PlugInName + 'Plugins\NPSWF32.dll';
end
else
//found IEExplorer
begin
BrowserStr := 'Internet Explorer';

DPChar := StrAlloc(255);
GetSystemDirectory(DPChar, 255);
PluginName := DPChar + '\Macromed\Flash\swflash.ocx';
DPChar := nil;
end;

GetVersion(pluginName);

//returned Version Number, may be checked
while mainVersion < 4 do
begin
if messagedlg(Text[2], mtInformation, [mbYes, mbNo], 0) = 6 then
begin
//installFlash;
end
// if message
else
halt;

getVersion(pluginName);
end; // while mainVer
end.




هنالك أيضاً مجموعة أخرى أتمنى أن تعجبكم هذه المجموعة....

[issamdnn]

أحببت أن أجعل هذه المجموعة الجديدة في ملف وورد 2007 أتمنى أيضاً أن تنال أعجاب الأعضاء وتساعد المهتمين بموضوع الصوتيات:

ملاحظة: بعض الأكواد تتطلب وحدة قمت بإضافتها ايضاً بالمرفقات

[قديم الشوق]

واصل الله يجزااك خير بالنسبه للمجموعه جديده لوتحوله الى وورد 2003

علشان تنفتح عند الجميع ولا بملف المفكره

وشكراً مره اخرى

[issamdnn]

أخي العزيز إليك الملف بصيغة تتوافق مع ورد 2003 وورد97 ..

أتمنى لك التوفيق