Delphi控件源码

开发平台：
Delphi

ACMWaveOut.pas：源码内容
							unit ACMWaveOut;
interface
uses
  msacm, mmsystem, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
  TACMWaveOut = class(TWinControl)
  private
    FOnDone: TNotifyEvent;
    procedure WaveOutCallback(var msg: TMessage); message MM_WOM_DONE;
    { Private declarations }
  protected
    procedure TWMPaint(var msg: TWMPaint); message WM_PAINT;
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    //destructor Destroy;
    procedure Open(format: PWaveFormatEx; DeviceID: Integer = 0);
    procedure PlayBack(data: pointer; size: longint);
    procedure Close;
    procedure Reset;
    function getsample: cardinal;
  published
    { Published declarations }
    property OnDone: TNotifyEvent read FOnDone write FOnDone;
  end;
var
  HWaveOut1: PHWaveOut;
  closed: boolean;
procedure Register;
implementation
constructor TACMWaveOut.create(AOwner: TComponent);
begin
  inherited Create(AOWner);
  width := 32;
  height := 32;
  Visible := false;
end;
procedure TACMWaveOut.TWMPaint(var msg: TWMPaint); //draw icon
var
  icon: HIcon;
  dc: HDC;
begin
  if csDesigning in ComponentState then
  begin
    icon := LoadIcon(HInstance, MAKEINTRESOURCE('TACMWAVEOUT'));
    dc := GetDC(Handle);
    DrawIcon(dc, 0, 0, icon);
    Width := 32;
    Height := 32;
    ReleaseDC(Handle, dc);
    FreeResource(icon);
  end;
  ValidateRect(Handle, nil);
end;
procedure TACMWaveOut.Open(format: PWaveFormatEx; DeviceID: Integer = 0);
var
  waveformat: PWaveFormatEx;
  maxsizeformat, i: integer;
begin
  if (format <> nil) and (HWaveOut1 = nil) then
  begin
    acmMetrics(0, ACM_METRIC_MAX_SIZE_FORMAT, MaxSizeFormat);
    getmem(WaveFormat, MaxSizeFormat);
    move(format^, waveformat^, maxsizeformat);
    HWaveOut1 := new(PHWaveOut);
     //create playing handle with waveformatex structure
    i := WaveOutOpen(HWaveOut1, DeviceID, waveformat, handle, 0, CALLBACK_WINDOW or WAVE_MAPPED);
    if i <> 0 then
    begin
      raise Exception.Create('Problem creating playing handle' + inttostr(i));
      //showmessage('Problem creating playing handle' + inttostr(i));
      exit;
    end;
    closed := false;
  end;
end;
procedure TACMWaveOut.PlayBack(data: pointer; size: longint);
var
  Header: PWaveHdr;
  memblock: pointer;
  i: integer;
begin
  if HWaveOut1 <> nil then
  begin
    header := new(PWaveHdr);
    memblock := new(pointer);
    getmem(memblock, size);
    move(data^, memBlock^, size);
    header.lpdata := memBlock;
    header.dwbufferlength := size;
    header.dwbytesrecorded := size;
    header.dwUser := 0;
    header.dwflags := 0;
    header.dwloops := 0;
    i := WaveOutPrepareHeader(HWaveOut1^, header, sizeof(TWaveHdr));  
    if i <> 0 then raise Exception.Create('WaveOutPrepareHeader error');
    i := WaveOutWrite(HWaveOut1^, header, sizeof(TWaveHdr));
    if i <> 0 then raise Exception.Create('WaveOutWrite error');
  end;
end;
procedure TACMWaveOut.WaveOutCallback(var msg: TMessage);
var header: PWaveHdr;
  i: integer;
begin
  header := PWaveHdr(msg.LParam);
  if closed = false then
  begin
    i := WaveOutUnPrepareHeader(HWaveOut1^, header, sizeof(TWaveHdr));
    if i <> 0 then raise Exception.Create('WaveOutPrepareHeader error');
  end;
  if assigned(FOnDone) then
  begin
    FOnDone(self);
  end;
  dispose(Header^.lpData);
  dispose(Header);
end;
procedure TACMWaveOut.Close;
begin
  if HWaveOut1 <> nil then
  begin
    closed := TRUE;
    WaveOutReset(HWaveOut1^);
    WaveOutClose(HWaveOut1^);
    HWaveOut1 := nil;
  end;
end;
procedure TACMWaveOut.Reset;
begin
  if HWaveOut1 <> nil then
  begin
    WaveOutReset(HWaveOut1^);
  end;
end;
procedure Register;
begin
  RegisterComponents('Milos', [TACMWaveOut]);
end;
function TACMWaveOut.getsample: cardinal;
var
  mt: TMMTime;
begin
  mt.wType := TIME_SAMPLES;
  if Closed then exit;
  waveOutGetPosition(HWaveout1^, @mt, sizeof(mt));
  Result := mt.sample;
end;
end.

						