mmleds.pas

一套及时通讯的原码

       property OnDblClick;
       property OnMouseDown;
       property OnMouseMove;
       property OnMouseUp;
       property OnChange: TNotifyEvent read FOnChange write FOnChange;
       property OnDownClick: TNotifyEvent read FOnDownClick write FOnDownClick;
       property OnUpClick: TNotifyEvent read FOnUpClick write FOnUpClick;

       property Bevel: TMMBevel read GetLEDBevel write SetLEDBevel;
       property ParentShowHint;
       property ShowHint;
       property Visible;
       property Color: TColor read GetColor write SetColor default clBlack;
       property DrawInactive: Boolean read GetDrawInactive write SetDrawInactive default True;
       property Enabled: Boolean read GetEnabled write SetEnabled;
       property LEDColor: TColor read GetLEDColor write SetLEDColor;
       property InactiveColor: TColor read GetInactiveColor write SetInactiveColor;
       property NumDigits: integer read GetNumDigits write SetNumDigits;
       property DigitSize: TMMLEDSize read GetSize write SetSize;
       property LEDSpace: integer read GetLEDSpace write SetLEDSpace;
       property Space: integer read FSpace write SetSpace default 2;
       property TabStop: Boolean read GetTabStop write setTabStop default True;
       property TabOrder;
       property Increment: Longint read GetIncrement write SetIncrement;
       property ZeroBlank: Boolean read GetZeroBlank write SetZeroBlank;
       property MaxValue: LongInt read GetMaxValue write SetMaxValue;
       property MinValue: LongInt read GetMinValue write SetMinValue;
       property Value: Longint read GetValue write SetValue;
       property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;
       property DownNumGlyphs: TNumGlyphs read GetDownNumGlyphs write SetDownNumGlyphs;
       property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;
       property UpNumGlyphs: TNumGlyphs read GetUpNumGlyphs write SetUpNumGlyphs;
       property ButtonFace: Boolean read GetButtonFace write SetButtonFace;
       property MiddleButton: Boolean read GetMiddleButton write SetMiddleButton;
       property SpinBevel: TMMBevel read GetSpinBevel write SetSpinBevel;
    end;

implementation

const
     RC_NumDigits    = 11;     { number of digits in the resource file    }
     RC_NumSeparators= 4;      { number of separators in resource file    }

{$IFDEF WIN32}
  {$R MMLEDS.D32}
{$ELSE}
  {$R MMLEDS.D16}
{$ENDIF}

{ these mode resource are available: }
{ 'LCD_MODE'   }
{ these digit resources are available: }
{ 'LCD_06X07' }
{ 'LCD_07X11' }
{ 'LCD_08X13' }
{ 'LCD_11X19' }
{ 'LCD_13X20' }
{ 'LCD_13X21' }
{ 'LCD_15X24' }
{ 'LCD_15X25' }
{ 'LCD_18X25' }
{ 'LCD_21X37' }
{ 'LCD_23X41' }
{ these separator resources are available: }
{ 'LCDS_06X07' }
{ 'LCDS_07X11' }
{ 'LCDS_08X13' }
{ 'LCDS_11X19' }
{ 'LCDS_13X20' }
{ 'LCDS_13X21' }
{ 'LCDS_15X24' }
{ 'LCDS_15X25' }
{ 'LCDS_18X25' }
{ 'LCDS_21X37' }
{ 'LCDS_23X41' }

{-- TMMLED ---------------------------------------------------------------}
constructor TMMLED.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);

     ControlStyle := ControlStyle - [csSetCaption];

     FBeveledRect := BeveledRect;
     Height := 8;
     Width := 16;
     FEnabled := True;
     Color := clGreen;
     FLEDColor := clLime;

     ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
     if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMLED ---------------------------------------------------------------}
Procedure TMMLED.SetLEDColor(aValue: TColor);
begin
     if (aValue <> FLEDColor) then
     begin
          FLEDColor := aValue;
          Invalidate;
     end;
end;

{-- TMMLED ---------------------------------------------------------------}
procedure TMMLED.SetEnabled(aValue: Boolean);
begin
     if (aValue <> FEnabled) then
     begin
          FEnabled := aValue;
          if (Caption = '') then
              DrawLED
          else
              Repaint;
     end;
end;

{-- TMMLED ---------------------------------------------------------------}
procedure TMMLED.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
     inherited SetBounds(aLeft, aTop, aWidth, aHeight);
     FBeveledRect := BeveledRect;
end;

{-- TMMLED ---------------------------------------------------------------}
Procedure TMMLED.Changed;
begin
     FBeveledRect := BeveledRect;
     inherited Changed;
end;

{-- TMMLED ---------------------------------------------------------------}
procedure TMMLED.CMTextChanged(var Message: TMessage);
begin
   Refresh;
end;

{-- TMMLED ---------------------------------------------------------------}
Procedure TMMLED.DrawLED;
var
   aRect: TRect;
   FontHeight: Integer;
   Text: PChar;

begin
     {$IFNDEF BUILD_ACTIVEX}
     if (Parent <> nil) and Parent.HandleAllocated then
     {$ENDIF}
     with Canvas do
     begin
        if assigned(FOnPaint) then
           FOnPaint(Self,Canvas,ClientRect)
        else
        begin
           if FEnabled then
              Brush.Color := FLEDColor
           else
              Brush.Color := Color;
           FillRect(FBeveledRect);
           if (Caption <> '') then
           begin
              Text := StrAlloc(Length(Caption)+1);
              try
                 StrPCopy(Text, Caption);
                 Brush.Style := bsClear;
                 Font := Self.Font;
                 FontHeight := TextHeight('W');
                 with aRect do
                 begin
                    Top := ((Bottom + Top) - FontHeight) shr 1;
                    Bottom := Top + FontHeight;
                 end;
                 DrawText(Handle, Text, StrLen(Text), aRect, (DT_EXPANDTABS or
                          DT_VCENTER) or DT_CENTER);

              finally
                 StrDispose(Text);
              end;
           end;
        end;
     end;
end;

{-- TMMLED ---------------------------------------------------------------}
Procedure TMMLED.Paint;
begin
   inherited Paint;                                    { draw the bevel }
   DrawLED;
end;

{== TMMLEDMode ===========================================================}
constructor TMMLedMode.Create (AOwner: TComponent);
begin
     FBitmap := TBitmap.Create;

     inherited Create (AOwner);

     Width := 27;
     Height := 11;
     FEnabled := True;      { !!!!!!!! ev. wieder zu inherited 鋘dern }
     FMode := mMono;
     FDrawInactive := True;
     FInactiveColor := clGreen;
     LEDColor := clLime;

     ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
     if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMLEDMode -----------------------------------------------------------}
destructor TMMLedMode.Destroy;
begin
     FBitmap.Free;
     inherited Destroy;
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLEDMode.LoadNewResource;
begin                                                { load the resource }
     FBitmap.Handle := LoadBitmap(HInstance, 'LCD_MODE');

     { Change the black/white resource to a colored bitmap }
     ChangeColors(FBitmap,FDrawInactive,FLEDColor,FInactiveColor,Color);
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLedMode.SetMode(aValue: TMMMode);
begin
     if (aValue <> FMode) then
     begin
          FMode := aValue;
          Invalidate;
     end;
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLEDMode.CMColorChanged(var Message: TMessage);
begin
     LoadNewResource;
     Invalidate;
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLEDMode.SetEnabled(aValue: Boolean);
begin
     {inherited Enabled := aValue;}
     FEnabled := aValue;       { !!!!!!!! ev. wieder zu inherited 鋘dern }
     Invalidate;
end;

{-- TMMLEDMode -----------------------------------------------------------}
function  TMMLEDMode.GetEnabled: Boolean;
begin
     {Result := inherited Enabled;}
     Result := FEnabled;       { !!!!!!!! ev. wieder zu inherited 鋘dern }
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLedMode.SetLEDColor(aColor: TColor);
begin
     if (aColor <> FLEDColor) then
     begin
          FLEDColor := aColor;
          LoadNewResource;
          Invalidate;
     end;
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLedMode.SetInactiveColor(aColor: TColor);
begin
     if (aColor <> FInactiveColor) then
     begin
          FInactiveColor := aColor;
          LoadNewResource;
          Invalidate;
     end;
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLedMode.SetDrawInactive(aValue: Boolean);
begin
     if (FDrawInactive <> aValue) then
     begin
          FDrawInactive := aValue;
          LoadNewResource;
          Invalidate;
     end;
end;

{-- TMMLEDMode -----------------------------------------------------------}
procedure TMMLedMode.Paint;
Var
   MemDC: HDC;
   oldBitmap: HBitmap;
   BitmapOfs: integer;

begin
     MemDC := CreateCompatibleDC(0);
     oldBitmap := SelectObject(MemDC, FBitmap.Handle);
     BitmapOfs := (FBitmap.Width div 4) * (Ord(FMode)+1) * Ord(Enabled);
     StretchBlt(Canvas.Handle,
                0, 0, Width, Height,
                MemDC,
                BitmapOfs, 0,
                FBitmap.Width div 4, FBitmap.Height,
                SRCCOPY);
     SelectObject(MemDC, oldBitmap);
     DeleteDC(MemDC);
end;

{=========================================================================}
type
    PDigitBitmap = ^TDigitBitmap;
    TDigitBitmap = record
       FBitmap    : TBitmap;
       FType      : TMMLEDType;
       FSize      : TMMLEDSize;
       FInactive  : Boolean;
       FColor     : TColor;
       FLEDColor  : TColor;
       FInactColor: TColor;
       FCount     : integer;
    end;

    TDigitCache = class
    public
       BitmapList: TList;
       constructor Create;
       destructor Destroy; override;

       function  Empty: Boolean;
       function  LoadBitmap(Typ: TMMLEDType; Size: TMMLEDSize; Inactive: Boolean;
                            LEDColor, InactColor,Color: TColor): TBitmap;
       procedure RemoveBitmap(var Bitmap: TBitmap);
    end;

const
   DigitCache : TDigitCache = nil;

{== TDigitCache ==========================================================}
constructor TDigitCache.Create;
begin
   inherited Create;
   BitmapList := TList.Create;
end;

{-- TDigitCache ----------------------------------------------------------}
destructor TDigitCache.Destroy;
begin
   BitmapList.Free;
   inherited Destroy;
end;

{-- TDigitCache ----------------------------------------------------------}
function TDigitCache.Empty: Boolean;
begin
   Result := BitmapList.Count = 0;
end;

{-- TDigitCache ----------------------------------------------------------}
function TDigitCache.LoadBitmap(Typ: TMMLEDType; Size: TMMLEDSize; Inactive: Boolean;
                                LEDColor,InactColor,Color: TColor): TBitmap;
Var
   DigitBitmap: PDigitBitmap;
   Str1: array[0..80] of Char;
   i: integer;

begin
   if (BitmapList.Count > 0) then
   begin
      { look if we have such a bitmap always in the cache }
      for i := 0 to BitmapList.Count-1 do
      with PDigitBitmap(BitmapList.Items[i])^ do
      begin
         if (Typ = FType) and (Size = FSize) and (Inactive = FInactive) and
            (Color = FColor) and (LEDColor = FLEDColor) and (InactColor = FInactColor) then
         begin
            inc(FCount);
            Result := FBitmap;
            exit;
         end;
      end;
   end;

   { load and prepare a new bitmap resource }
   if (Typ = ltDigit) then
   case Size of
        ls06x07: StrCopy(str1, 'LCD_06X07');
        ls07x11: StrCopy(str1, 'LCD_07X11');
        ls08x13: StrCopy(str1, 'LCD_08X13');
        ls11x19: StrCopy(str1, 'LCD_11X19');
        ls13x20: StrCopy(str1, 'LCD_13X20');
        ls13x21: StrCopy(str1, 'LCD_13X21');
        ls15x24: StrCopy(str1, 'LCD_15X24');
        ls15x25: StrCopy(str1, 'LCD_15X25');
        ls17x29: StrCopy(str1, 'LCD_17X29');
        ls18x25: StrCopy(str1, 'LCD_18X25');
        ls19x33: StrCopy(str1, 'LCD_19X33');
        ls21x37: StrCopy(str1, 'LCD_21X37');
        ls23x41: StrCopy(str1, 'LCD_23X41');
   end
   else
   case Size of
        ls06x07: StrCopy(str1, 'LCDS_06X07');
        ls07x11: StrCopy(str1, 'LCDS_07X11');
        ls08x13: StrCopy(str1, 'LCDS_08X13');
        ls11x19: StrCopy(str1, 'LCDS_11X19');
        ls13x20: StrCopy(str1, 'LCDS_13X20');
        ls13x21: StrCopy(str1, 'LCDS_13X21');
        ls15x24: StrCopy(str1, 'LCDS_15X24');
        ls15x25: StrCopy(str1, 'LCDS_15X25');
        ls17x29: StrCopy(str1, 'LCDS_17X29');