PC Format Collection 48/SENT14D.ISO/tech/delphi/disk15/ushlpdmo.pak/STEREO.PAS

Pascal/Delphi Source File | 1995-08-24 | 9.1 KB | 364 lines

unit Stereo;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Buttons;

type
  TStereoButton = class(TGraphicControl)
  private
    { Private declarations }
    FDown: Boolean;
    FDragging: Boolean;
    FLightColor: array[Boolean] of TColor;
    FState: TButtonState;
    FOn: Boolean;
    function GetStateColor(Index: Integer): TColor;
    procedure SetStateColor(Index: Integer; Value: TColor);
    procedure SetOn(Value: Boolean);
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Click; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    property OnColor: TColor index Ord(True) read GetStateColor write SetStateColor;
    property OffColor: TColor index Ord(False) read GetStateColor write SetStateColor;
    property IsOn: Boolean read FOn write SetOn;
    property Caption;
    property Font;
    property ParentFont;
    property ShowHint;
    property ParentShowHint;
    property DragMode;
    property Visible;
    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

  TStereoSpeaker = class(TGraphicControl)
  private
    FWaveFile: PString;
    Bitmap: TBitmap;
    function GetWaveFile: string;
    procedure SetWaveFile(const Value: string);
  protected
    procedure Click; override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property WaveFile: string read GetWaveFile write SetWaveFile;
    property Visible;
    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property ShowHint;
    property ParentShowHint;
    property DragMode;
  end;

procedure Register;

implementation

uses MMSystem, DsgnIntf;

{$R STEREO.RES}

type
  TWaveFileProperty = class(TStringProperty)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
  end;

{ TStereoButton }

constructor TStereoButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 65;
  Height := 35;
  FLightColor[True] := clLime;
  FLightColor[False] := clMaroon;
  ParentFont := True;
end;

function TStereoButton.GetStateColor(Index: Integer): TColor;
begin
  Result := FLightColor[Boolean(Index)];
end;

procedure TStereoButton.SetStateColor(Index: Integer; Value: TColor);
begin
  FLightColor[Boolean(Index)] := Value;
  Repaint;
end;

procedure TStereoButton.SetOn(Value: Boolean);
begin
  if Value <> FOn then
  begin
    FOn := Value;
    Repaint;
  end;
end;

procedure TStereoButton.Paint;
const
  LightWidth = 15;
  LightHeight = 8;
  LightTop = 6;
var
  TextLeft: Integer;
  R: TRect;
  CStr: array[0..255] of Char;
begin
  with Canvas do
  begin
    Pen.Color := clWindowFrame;
    Brush.Color := clBtnFace;
    Brush.Style := bsSolid;
    Rectangle(0, 0, Width, Height);

    if FState = bsDown then Pen.Color := clBtnShadow
    else Pen.Color := clBtnHighlight;
    MoveTo(1, 1); LineTo(Width - 1, 1);
    MoveTo(2, 2); LineTo(Width - 2, 2);

    if FState = bsDown then Pen.Color := clBtnHighlight
    else Pen.Color := clBtnShadow;
    MoveTo(1, Height - 2); LineTo(Width - 1, Height - 2);
    if FState <> bsDown then
    begin
      MoveTo(2, Height - 3);
      LineTo(Width - 2, Height - 3);
    end;

    R := Bounds((Width div 2) - (LightWidth div 2), LightTop, LightWidth,
      LightHeight);
    if FState = bsDown then OffsetRect(R, 0, 1);

    { draw light's bounding rectangle }
    Pen.Color := clBtnShadow;
    PolyLine([Point(R.Left, R.Bottom), R.TopLeft, Point(R.Right + 1, R.Top)]);
    Pen.Color := clBtnHighlight;
    PolyLine([Point(R.Left, R.Bottom), R.BottomRight, Point(R.Right, R.Top)]);

    { draw the light }
    OffsetRect(R, 1, 1);
    Dec(R.Right);
    Dec(R.Bottom);
    if Enabled then Brush.Color := FLightColor[FOn]
    else Brush.Color := clBtnFace;
    FillRect(R);

    { draw the button's caption }
    Canvas.Font := Self.Font;
    Brush.Style := bsClear;
    R := Bounds(0, R.Bottom, Self.Width, 0);
    R.Bottom := Self.Height;
    if FState = bsDown then OffsetRect(R, 0, 1);

    StrPCopy(CStr, Caption);
    if not Enabled then
    begin
      OffsetRect(R, 1, 1);
      Font.Color := clBtnHighlight;
      DrawText(Handle, CStr, -1, R, DT_VCENTER or DT_CENTER or DT_SINGLELINE);
      OffsetRect(R, -1, -1);
      Font.Color := clBtnShadow;
      DrawText(Handle, CStr, -1, R, DT_VCENTER or DT_CENTER or DT_SINGLELINE);
    end
    else
      DrawText(Handle, CStr, -1, R, DT_VCENTER or DT_CENTER or DT_SINGLELINE);
  end;
end;

procedure TStereoButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if not FDown then
    begin
      FState := bsDown;
      Repaint;
    end;
    FDragging := True;
  end;
end;

procedure TStereoButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if not FDown then NewState := bsUp;

    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then NewState := bsUp else NewState := bsDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Repaint;
    end;
  end;
end;

procedure TStereoButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    DoClick := FDown and (X >= 0) and (X < ClientWidth) and (Y >= 0) and
      (Y <= ClientHeight);
    FState := bsUp;
    Repaint;
    if DoClick then Click;
  end;
end;

procedure TStereoButton.Click;
begin
  FOn := not FOn;
  inherited Click;
end;

procedure TStereoButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TStereoButton.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TStereoButton.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TStereoButton.CMSysColorChange(var Message: TMessage);
begin
  Invalidate;
end;

procedure TStereoButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

{ TStereoSpeaker }
constructor TStereoSpeaker.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Bitmap := TBitmap.Create;
  Bitmap.Handle := LoadBitmap(HInstance, 'SPEAKER');
  FWaveFile := NullStr;
  Width := Bitmap.Width;
  Height := Bitmap.Height;
end;

destructor TStereoSpeaker.Destroy;
begin
  Bitmap.Free;
  DisposeStr(FWaveFile);
  inherited Destroy;
end;

function TStereoSpeaker.GetWaveFile: string;
begin
  Result := FWaveFile^;
end;

procedure TStereoSpeaker.SetWaveFile(const Value: string);
begin
  AssignStr(FWaveFile, Value);
end;

procedure TStereoSpeaker.Paint;
var
  F: TForm;
begin
  F := GetParentForm(Self);
  if F <> nil then Canvas.Brush.Color := F.Color;
  Canvas.BrushCopy(Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap,
    Bounds(0, 0, Bitmap.Width, Bitmap.Height),
    Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]);
end;

procedure TStereoSpeaker.Click;
var
  CWaveFile: array[0..255] of Char;
begin
  if WaveFile > '' then
    sndPlaySound(StrPCopy(CWaveFile, WaveFile), snd_Sync);
end;

{ TWaveFileProperty }
procedure TWaveFileProperty.Edit;
var
  FileOpen: TOpenDialog;
begin
  FileOpen := TOpenDialog.Create(Application);
  FileOpen.Filename := GetValue;
  FileOpen.Filter := 'Wave files (*.wav)|*.WAV|All files (*.*)|*.*';
  FileOpen.Options := FileOpen.Options + [ofPathMustExist, ofFileMustExist];
  try
    if FileOpen.Execute then SetValue(FileOpen.Filename);
  finally
    FileOpen.Free;
  end;
end;

function TWaveFileProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog];
end;

procedure Register;
begin
  RegisterComponents('Samples', [TStereoButton, TStereoSpeaker]);
  RegisterPropertyEditor(TypeInfo(string), TStereoSpeaker, 'WaveFile',
    TWaveFileProperty);
end;

end.