Delphi控件源码

开发平台：
Delphi

MMSwitch.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49 (0)351-8037944              =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 09.07.98 - 15:28:53 $                                        =}
{========================================================================}
unit MMSwitch;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils, 
    Messages, 
    Classes, 
    Graphics, 
    Controls,
    Buttons,
    MMUtils,
    MMString,
    MMObj;
type
  TMMSwitchKind = (skHorizontal, skVertical);
  {-- TMMSwitch ----------------------------------------------------------}
  TMMSwitch = class(TMMCustomControl)
  private
    FStandardBit : Boolean;          { True if the standard bitmap is used}    
    FGlyph       : TBitmap;          { this our glyph                     }
    FNumGlyphs   : TNumGlyphs;       { number of glyphs in the bitmap     }
    FSwitchRect  : TRect;            { current switch position            }
    FCapture     : Boolean;          { Whether it's currently being moved }
    FCapturePoint: TPoint;           { Position at start of capture.      }
    FCaptureValue: Integer;          { Value at start of capture.         }
    FKind        : TMMSwitchKind;    { skVertical or skHorizontal         }
    FNumPositions: Integer;          { number of switch positions         }
    FPosition    : Integer;          { current switch position            }
    FOnChange    : TNotifyEvent;
    procedure SetKind(aValue : TMMSwitchKind);
    procedure SetNumPositions(aValue: integer);
    procedure SetPosition(aValue: integer);
    procedure SetGlyph(aValue: TBitmap);
    procedure SetNumGlyphs(aValue: TNumGlyphs);
    procedure LoadNewResource;
    procedure AdjustSize(var W, H: Integer);
    procedure AdjustBounds;
    procedure DrawSwitch;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    {$IFDEF BUILD_ACTIVEX}
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    {$ENDIF}
  protected
    procedure Change; dynamic;
    procedure Paint; override;
    procedure Loaded; override;
    procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); override;
    procedure Changed; override;
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove (Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create (AOwner : TComponent); override;
    destructor  Destroy; override;
  published
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Bevel;
    property Color;
    property Enabled;
    property HelpContext;
    property Hint;
    property ParentColor;
    property ParentShowHint;
    property ShowHint;
    property TabStop default True;
    property TabOrder;
    property Tag;
    property Visible;
    property Width default 1;
    property Height default 1;
    property Kind: TMMSwitchKind read FKind write SetKind;
    property NumPositions: integer read FNumPositions write SetNumPositions;
    property Position: Integer read FPosition write SetPosition;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;
  end;
implementation
{$IFDEF WIN32}
  {$R MMSWITCH.D32}
{$ELSE}
  {$R MMSWITCH.D16}
{$ENDIF}
{ these resources are available: }
{ 'H_SWITCH' }
{ 'V_SWITCH' }
{-- TMMSwitch ------------------------------------------------------------}
constructor TMMSwitch.Create (AOwner : TComponent);
begin
   inherited Create (AOwner);
   FGlyph := TBitmap.Create;
   FNumGlyphs := 1;
   Width := 1;
   Height := 1;
   FKind := skVertical;
   FNumPositions := 2;
   FPosition := 0;
   FOnChange := Nil;
   FCapture := False;
   TabStop := True;
   LoadNewResource;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMSwitch ------------------------------------------------------------}
destructor TMMSwitch.Destroy;
begin
   FGlyph.Free;
   inherited Destroy
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.Change;
begin
   if not (csLoading in ComponentState) and 
      not (csReading in ComponentState) then
      if Assigned(FOnChange) then FOnChange(self);
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.LoadNewResource;
var
   Str1: array[0..80] of Char;
begin
   if (FKind = skVertical) then 
      StrCopy(str1, 'V_SWITCH')
   else 
      StrCopy(str1, 'H_SWITCH');
                                                      { load the resource }
   FGlyph.Handle := LoadBitmap(HInstance, Str1);
   FNumGlyphs := 3;
   AdjustBounds;
   FStandardBit := True;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.SetGlyph(aValue: TBitmap);
begin
   if (aValue <> FGlyph) then
   begin
      if aValue <> Nil then
      begin
         FGlyph.Assign(aValue);
         FStandardBit := False;
         AdjustBounds;
      end
      else LoadNewResource;
      Invalidate;
   end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.SetNumGlyphs(aValue: TNumGlyphs);
begin
     if (aValue <> FNumGlyphs) then
     begin
        FNumGlyphs := aValue;
        AdjustBounds;
        Invalidate;
     end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.CMEnabledChanged(var Message: TMessage);
begin
   Invalidate;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.WMSetFocus(var Message: TWMSetFocus);
begin
     Invalidate;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.WMKillFocus(var Message: TWMKillFocus);
begin
     Invalidate;
end;
{$IFDEF BUILD_ACTIVEX}
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.WMSize(var Message: TWMSize);
begin
   inherited;
   AdjustBounds;
end;
{$ENDIF}
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.SetKind(aValue: TMMSwitchKind);
begin
   if (aValue <> FKind) then
   begin
      FKind := aValue;
      if FStandardBit then LoadNewResource
      else AdjustBounds;
      Invalidate;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.SetNumPositions(aValue: integer);
begin
   if (aValue <> FNumPositions) and (aValue > 1) then
   begin
      FNumPositions := aValue;
      FPosition := Min(FPosition, FNumPositions-1);
      AdjustBounds;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.SetPosition(aValue: integer);
begin
   aValue := MinMax(aValue, 0, FNumPositions-1);
   if aValue <> FPosition then
   begin
      FPosition := aValue;
      Change;
      if (csDesigning in ComponentState) then
          Invalidate
      else if Enabled then DrawSwitch;
   end
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.KeyDown(var Key: Word; Shift: TShiftState);
begin
   inherited KeyDown(Key, Shift);
   case Key of
     VK_END  : Position := FNumPositions-1;
     VK_HOME : Position := 0;
     VK_UP   : if FKind = skVertical then Position := Position -1;
     VK_DOWN : if FKind = skVertical then Position := Position + 1;
     VK_LEFT : if FKind = skHorizontal then Position := Position - 1;
     VK_RIGHT: if FKind = skHorizontal then Position := Position + 1;
   end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
   Message.Result := DLGC_WANTARROWS;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited MouseDown(Button, Shift, X, Y);
   if (Button = mbLeft) and Enabled then
   begin
      SetFocus;
      if PtInRect(FSwitchRect, Point(X, Y)) then
      begin
         FCapture := True;
         FCapturePoint := Point(X, Y);
         FCaptureValue := FPosition;
         Invalidate;
      end
      else
      begin
         if FKind = skVertical then
            Position := (Y - BevelExtend) div FGlyph.Height
         else
            Position := (X - BevelExtend) div (FGlyph.Width div FNumGlyphs);
      end;
   end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   inherited MouseUp(Button, Shift, X, Y);
   if (Button = mbLeft) and FCapture then
   begin
      FCapture := False;
      Invalidate;
   end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
   inherited MouseMove(Shift, X, Y);
   if FCapture then
   begin
      if FKind = skVertical then
         Position := FCaptureValue+FNumPositions*(Y-FCapturePoint.Y)div(Height-2*BevelExtend-FGlyph.Height)
      else
         Position := FCaptureValue+FNumPositions*(X-FCapturePoint.X)div(Width-2*BevelExtend-FGlyph.Width div FNumGlyphs);
   end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
var
  W, H: Integer;
begin
   W := aWidth;
   H := aHeight;
   AdjustSize (W, H);
   inherited SetBounds(aLeft, aTop, W, H);
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.AdjustSize(var W, H: Integer);
begin
   if (csLoading in ComponentState) then Exit;
   if FKind = skVertical then
   begin
      W := FGlyph.Width div FNumGlyphs;
      H := FNumPositions * FGlyph.Height;
   end
   else
   begin
      W := FNumPositions * FGlyph.Width div FNumGlyphs;
      H := FGlyph.Height;
   end;
   inc(H,2*BevelExtend);
   inc(W,2*BevelExtend);
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.AdjustBounds;
var
  W, H: Integer;
begin
   W := Width;
   H := Height;
   AdjustSize(W, H);
   if (W <> Width) or (H <> Height) then
   begin
      FSwitchRect.Left := -1;
      inherited SetBounds(Left, Top, W, H);
   end
   else Invalidate;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.Changed;
begin
   AdjustBounds;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.Loaded;
begin
   inherited Loaded;
   AdjustBounds;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.DrawSwitch;
var
   SrcRect: TRect;
begin
   if Visible then
   with Canvas do
   begin
      Brush.Color := Color;
      { clear the old switch }
      if FSwitchRect.Left <> -1 then FillRect(FSwitchRect);
      if FKind = skVertical then
      begin
         FSwitchRect.Left := BevelExtend;
         FSwitchRect.Top := BevelExtend + FPosition * FGlyph.Height;
         FSwitchRect.Right := FSwitchRect.Left + FGlyph.Width div FNumGlyphs;
         FSwitchRect.Bottom := FSwitchRect.Top + FGlyph.Height;
      end
      else
      begin
         FSwitchRect.Left := BevelExtend + FPosition * FGlyph.Width div FNumGlyphs;
         FSwitchRect.Top := BevelExtend;
         FSwitchRect.Right := FSwitchRect.Left + FGlyph.Width div FNumGlyphs;
         FSwitchRect.Bottom := FSwitchRect.Top + FGlyph.Height;
      end;
      SrcRect := Rect(0,0,FGlyph.Width div FNumGlyphs,FGlyph.Height);
      if Not Enabled and (FNumGlyphs > 1) then
         OffsetRect(SrcRect, FGlyph.Width div FNumGlyphs, 0);
      if FCapture and (FNumGlyphs > 2) then
         OffsetRect(SrcRect, 2 * FGlyph.Width div FNumGlyphs, 0);
      { draw the new switch and change the backcolors }
      BrushCopy(FSwitchRect, FGlyph, SrcRect, FGlyph.Canvas.Pixels[0,0]);
      { draw the focus }
      if Focused then
      begin
         Pen.Color := clBlack;
         Brush.Style := bsClear;
         with BeveledRect do Rectangle(Left,Top,Right,Bottom);
      end;
   end;
end;
{-- TMMSwitch ------------------------------------------------------------}
procedure TMMSwitch.Paint;
begin
    { Draw the bevel }
    inherited Paint;
    DrawSwitch;
end;
end.

						