mmobj.pas

一套及时通讯的原码

begin
   Result := Instance.InheritsFrom(AClass)
end;
{$ENDIF}

{==============================================================================}
function LoadResStr(const ResID: Word): String;
begin
   Result := LoadStr(IDS_BASE + ResID);
end;

{==============================================================================}
function LoadResCursor(const ResID: Word): HCursor;
begin
   Result := LoadCursor(HInstance, PChar(crsBase + ResID));
end;

{==============================================================================}
function LoadResIcon(const ResID: Word): HIcon;
begin
   Result := LoadIcon(HInstance, PChar(icoBase + ResID));
end;

{$IFDEF WIN32}
{== TMMCriticalSection ========================================================}
procedure TMMCriticalSection.Acquire;
begin
   InterlockedIncrement(FlockCount);
   inherited;
end;

{-- TMMCriticalSection --------------------------------------------------------}
procedure TMMCriticalSection.Release;
begin
   inherited;
   InterlockedDecrement(FlockCount);
end;

{-- TMMCriticalSection --------------------------------------------------------}
function TMMCriticalSection.TryEnter: Boolean;
begin
   Result := FLockCount = 0;
   if Result then Enter;
end;

const
  Priorities: array [TThreadPriority] of Integer =
      (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST,
       THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_NORMAL,
       THREAD_PRIORITY_ABOVE_NORMAL, THREAD_PRIORITY_HIGHEST,
       THREAD_PRIORITY_TIME_CRITICAL);

{== TMMThreadEx ===============================================================}
procedure TMMThreadEx.SetPriority(Value: TThreadPriority);
begin
   MMSetThreadPriority(Handle, Priorities[Value]);
end;

{-- TMMThreadEx ---------------------------------------------------------------}
function TMMThreadEx.GetPriority: TThreadPriority;
begin
   Result := inherited Priority;
end;
{$ENDIF}

{== TMMObject =================================================================}
procedure TMMObject.BeginUpdate;
begin
   if FUpdateCount = 0 then SetUpdateState(True);
   inc(FUpdateCount);
end;

{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.EndUpdate;
begin
   dec(FUpdateCount);
   if FUpdateCount = 0 then SetUpdateState(False);
end;

{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.SetUpdateState(Updating: Boolean);
begin
  if Updating then Changing else Changed;
end;

{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.Changing;
begin
   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
end;

{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.Changed;
begin
   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
end;

{== TMMBevel ==================================================================}
constructor TMMBevel.Create;
begin
   inherited Create;

   FBevelInner      := bvNone;
   FBevelOuter      := bvLowered;
   FBevelInnerWidth := 1;
   FBevelOuterWidth := 1;
   FBorderStyle     := bsNone;
   FBorderWidth     := 0;
   FBorderSpace     := 0;
   FBorderColor     := clBtnFace;
   FBorderSpaceColor:= clBlack;
   FOuterLightColor := clBtnHighlight;
   FOuterShadowColor:= clBtnShadow;
   FInnerLightColor := clBtnHighlight;
   FInnerShadowColor:= clBtnShadow;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.Assign(Source: TPersistent);
begin
   if (Source is TMMBevel) and (Source <> Self) then
   begin
      BeginUpdate;
      try
         BevelInner      := TMMBevel(Source).BevelInner;
         BevelOuter      := TMMBevel(Source).BevelOuter;
         BevelInnerWidth := TMMBevel(Source).BevelInnerWidth;
         BevelOuterWidth := TMMBevel(Source).BevelOuterWidth;
         BorderStyle     := TMMBevel(Source).BorderStyle;
         BorderWidth     := TMMBevel(Source).BorderWidth;
         BorderSpace     := TMMBevel(Source).BorderSpace;
         BorderColor     := TMMBevel(Source).BorderColor;
         BorderSpaceColor:= TMMBevel(Source).BorderSpaceColor;
         OuterLightColor := TMMBevel(Source).OuterLightColor;
         OuterShadowColor:= TMMBevel(Source).OuterShadowColor;
         InnerLightColor := TMMBevel(Source).InnerLightColor;
         InnerShadowColor:= TMMBevel(Source).InnerShadowColor;
      finally
         EndUpdate;
      end;
   end
   else inherited assign(Source);
end;

{-- TMMBevel ------------------------------------------------------------------}
function TMMBevel.GetBevelExtend: Integer;
begin
   Result := FBorderWidth + FBorderSpace;
   if (FBevelOuter <> bvNone) then inc(Result, FBevelOuterWidth);
   if (FBevelInner <> bvNone) then inc(Result, FBevelInnerWidth);
   if (FBorderStyle <> bsNone) then inc(Result);
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelInner(Value: TPanelBevel);
begin
   if (Value <> FBevelInner) then
   begin
      FBevelInner := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelOuter(Value: TPanelBevel);
begin
   if (Value <> FBevelOuter) then
   begin
      FBevelOuter := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelInnerWidth(Value: TBevelWidth);
begin
   if (Value <> FBevelInnerWidth) then
   begin
      FBevelInnerWidth := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelOuterWidth(Value: TBevelWidth);
begin
   if (Value <> FBevelOuterWidth) then
   begin
      FBevelOuterWidth := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBorderStyle(Value: TBorderStyle);
begin
   if (Value <> FBorderStyle) then
   begin
      FBorderStyle := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBorderWidth(Value: TBorderWidth);
begin
   if (Value <> FBorderWidth) then
   begin
      FBorderWidth := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBorderSpace(Value: TBorderWidth);
begin
   if (Value <> FBorderSpace) then
   begin
      FBorderSpace := Value;
      Changed;
   end;
end;

{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetColors(Index:Integer; Value: TColor);
begin
   case Index of
     0: if FBorderColor = Value then exit else FBorderColor := Value;
     1: if FBorderSpaceColor = Value then exit else FBorderSpaceColor := Value;
     2: if FInnerLightColor = Value then exit else FInnerLightColor := Value;
     3: if FInnerShadowColor = Value then exit else FInnerShadowColor := Value;
     4: if FOuterLightColor = Value then exit else FOuterLightColor := Value;
     5: if FOuterShadowColor = Value then exit else FOuterShadowColor := Value;
   end;
   Changed;
end;

{-- TMMBevel ------------------------------------------------------------------}
function TMMBevel.PaintBevel(Canvas: TCanvas; FrameRect: TRect; Fill: Boolean): TRect;
begin
   if (FBorderStyle = bsSingle) then
      Frame3D(Canvas, FrameRect, clWindowFrame, clWindowFrame, 1);

   if (FBevelOuter = bvLowered) then
      Frame3D(Canvas, FrameRect, OuterShadowColor, OuterLightColor, FBevelOuterWidth)
   else if (FBevelOuter = bvRaised) then
      Frame3D(Canvas, FrameRect, OuterLightColor, OuterShadowColor, FBevelOuterWidth);

   if Fill then
      Frame3D(Canvas, FrameRect, FBorderColor, FBorderColor, FBorderWidth)
   else
      InflateRect(FrameRect, -FBorderWidth, -FBorderWidth);

   if (FBevelInner = bvLowered) then
      Frame3D(Canvas, FrameRect, InnerShadowColor, InnerLightColor, FBevelInnerWidth)
   else if (FBevelInner = bvRaised) then
      Frame3D(Canvas, FrameRect, InnerLightColor, InnerShadowColor, FBevelInnerWidth);

   if (FBorderSpace <> 0) then
      Frame3D(Canvas, FrameRect, FBorderSpaceColor, FBorderSpaceColor, FBorderSpace);

   Result := FrameRect;
end;

{== TMMComponent ==============================================================}
procedure TMMComponent.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;

{-- TMMComponent --------------------------------------------------------------}
procedure TMMComponent.ChangeDesigning(aValue: Boolean);
begin
   SetDesigning(aValue);
end;

{$IFDEF BUILD_ACTIVEX}
{== TMMAXControl ==============================================================}
procedure TMMAXControl.SetSelected(aValue: Boolean);
begin
   if (aValue <> FSelected) then
   begin
      FSelected := aValue;
      Refresh;
   end;
end;

{== TMMNonVisualComponent =====================================================}
constructor TMMNonVisualComponent.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);

   { !!! set DesignMode as default because many constructors check for the flag !!! }
{$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
{$ENDIF}

   Width := defWidth;
   Height:= defHeight;

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

{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;

{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);
end;

{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if csDesigning in ComponentState then
    inherited SetBounds(ALeft, ATop, defWidth, defHeight)
  else
    inherited SetBounds(ALeft, ATop, 0, 0)
end;

{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.Paint;
var
   R: TRect;
   Bitmap: TBitmap;
   TransColor: TColor;

begin
   if (csNoDesignVisible in ControlStyle) then exit;

   //BringToFront;

   SetBounds(Left, Top, defWidth, defHeight);

   R := ClientRect;
   Frame3D(Canvas, R, clWhite, clBlack, 1);
   Frame3D(Canvas, R, clBtnFace, clGray, 1);
    // Paint like button no matter what Color property is
   Canvas.Brush.Color := clBtnFace;
   Canvas.FillRect(R);

   Bitmap := TBitmap.Create;
   try
      Bitmap.Handle := LoadBitmap(hInstance, PChar(UpperCase(ClassName)+'_X'));
      if (Bitmap.Handle = 0) then
          Bitmap.Handle := LoadBitmap(hInstance, PChar(UpperCase(ClassName)));
      if (Bitmap.Handle = 0) then
          Bitmap.Handle := LoadBitmap(hInstance, PChar(ToolBoxImageID));

      InflateRect(R, -((R.Right - R.Left) - Bitmap.Width) div 2,
                     -((R.Bottom - R.Top) - Bitmap.Height) div 2);
      TransColor := Bitmap.Canvas.Pixels[0,Bitmap.Height-1];
      Canvas.Brush.Color:= clBtnFace;
      Canvas.BrushCopy(R, Bitmap,
                       Rect(0, 0, Bitmap.Width, Bitmap.Height),
                       TransColor);

      if Selected then
      begin
         Canvas.Brush.Style := bsClear;
         Canvas.Pen.Color   := clRed;
         Canvas.Rectangle(0, 0, Width, Height);
         Canvas.Brush.Style := bsSolid;
      end;

   finally
      Bitmap.Free;
   end;
end;
{$ENDIF}

{== TMMWinControl =============================================================}
constructor TMMWinControl.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);

   { !!! set DesignMode as default because many constructors check for the flag !!! }
   {$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
   {$ENDIF}

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

{-- TMMWinControl -------------------------------------------------------------}
function TMMWinControl.ClientToClient(Source: TControl; const Point: TPoint): TPoint;
begin
   Result := ScreenToClient(Source.ClientToScreen(Point));
end;

{-- TMMWinControl -------------------------------------------------------------}
procedure TMMWinControl.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;

{-- TMMWinControl -------------------------------------------------------------}
procedure TMMWinControl.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);

   { update visible state }
   UpdateControlState;
end;

{== TMMCustomControl ==========================================================}
constructor TMMCustomControl.Create(aOwner:TComponent);
begin
   inherited Create(aOwner);

   ControlStyle := ControlStyle + [csOpaque];

   { !!! set DesignMode as default because many constructors check for the flag !!! }
   {$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
   Color  := clBtnFace;
   {$ENDIF}

   FBevel := TMMBevel.Create;
   FBevel.OnChange := BevelChanged;

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

{-- TMMCustomControl ----------------------------------------------------------}
destructor TMMCustomControl.Destroy;
begin
   FBevel.OnChange := Nil;
   FBevel.Free;

   inherited Destroy;
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);

   { update visible state }
   UpdateControlState;
end;

{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.ClientToClient(Source: TControl; const Point: TPoint): TPoint;
begin
   Result := ScreenToClient(Source.ClientToScreen(Point));
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.BevelChanged(Sender: TObject);
begin
   Changed;