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

مجموعة من أكواد التعامل مع الصوتيات - نسخة قابلة للطباعة

+- delphi4arab منتديات دلفي للعرب (https://delphi4arab.net/forum)
+-- قسم : منتديات دلفي للعرب التعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=3)
+--- قسم : مصادر دلفي مفتوحة تعليمية (https://delphi4arab.net/forum/forumdisplay.php?fid=14)
+--- الموضوع : مجموعة من أكواد التعامل مع الصوتيات (/showthread.php?tid=1519)

مجموعة من أكواد التعامل مع الصوتيات - issamdnn - 17-01-2010

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

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

PHP كود :
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 - 18-01-2010

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

فحص فيما إذا كان TMediaPlayer قد توقف عن تشغيل الصوت

PHP كود :
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

PHP كود :
{....}

  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 منصب أو موجود على النظام:

PHP كود :
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 - 19-01-2010

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

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

مجموعة من أكواد التعامل مع الصوتيات - قديم الشوق - 06-02-2010

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

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

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

مجموعة من أكواد التعامل مع الصوتيات - issamdnn - 07-02-2010

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

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