mmobj.pas

一套及时通讯的原码

end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.Changed;
begin
   Invalidate;
end;

{-- TMMCustomControl ----------------------------------------------------------}
Procedure TMMCustomControl.SetBevel(aValue: TMMBevel);
begin
   FBevel.Assign(aValue);
end;

{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.BevelExtend: Integer;
begin
   Result := 0;
   if (FBevel <> nil) then
       Result := FBevel.BevelExtend;
end;

{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.BeveledRect: TRect;
begin
   Result := Rect(0,0,Width,Height);
   InflateRect(Result, -BevelExtend, -BevelExtend);
end;

{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.ScreenRect(aRect: TRect): TRect;
begin
   with aRect do
   begin
      Result.TopLeft := ClienttoScreen(Point(Left,Top));
      Result.BottomRight := ClienttoScreen(Point(Right,Bottom));
   end;
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.Paint;
Var
   aRect: TRect;

begin
   { draw the Bevel and fill the area }
   aRect := FBevel.PaintBevel(Canvas, ClientRect, True);
   {$IFDEF BUILD_ACTIVEX}
   if not Transparent then
   {$ENDIF}
   with Canvas do
   begin
      Brush.Color := Color;
      Brush.Style := bsSolid;
      FillRect(aRect);
   end;
end;

{$IFDEF BUILD_ACTIVEX}
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.SetTransparent(aValue: Boolean);
begin
   if (aValue <> FTransparent) then
   begin
      FTransparent := aValue;
      if FTransparent
        then ControlStyle := ControlStyle - [csOpaque]
        else ControlStyle := ControlStyle + [csOpaque];
      if HandleAllocated then ReCreateWnd;
   end;
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.WMEraseBkgnd;
begin
   if Transparent then
      Message.Result := 1
   else
      inherited;
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.WMWindowPosChanging;
begin
   inherited;
   if Transparent then Invalidate;
end;

{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.CreateParams;
begin
   inherited;
   if Transparent then
      Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;
{$ENDIF}

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

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

   FOnPaint := nil;

   { make sure the inherited values are not used by aligncontrols !! }
   BorderWidth := 0;
   BevelOuter := bvNone;
   BevelInner := bvNone;

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

   FFillBevel := True;

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

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

   inherited Destroy;
end;

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

{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.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;

{-- TMMCustomPanel ------------------------------------------------------------}
Procedure TMMCustomPanel.SetBevel(aValue: TMMBevel);
begin
   FBevel.Assign(aValue);
end;

{-- TMMCustomPanel ------------------------------------------------------------}
Procedure TMMCustomPanel.SetFillBevel(aValue: Boolean);
begin
   if (aValue <> FFillBevel) then
   begin
      FFillBevel := aValue;
      Invalidate;
   end;
end;

{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.BevelChanged(Sender: TObject);
begin
   ReAlign;
   Changed;
end;

{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.AlignControls(aControl: TControl; Var Rect: TRect);
begin
   if (FBevel <> nil) then
      InflateRect(Rect, -FBevel.BevelExtend, -FBevel.BevelExtend);
   inherited AlignControls(aControl, Rect);
end;

{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.BevelExtend: integer;
begin
   Result := 0;
   if (FBevel <> nil) then
       Result := FBevel.BevelExtend;
end;

{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.BeveledRect: TRect;
begin
   Result := Rect(0,0,Width,Height);
   InflateRect(Result, -BevelExtend, -BevelExtend);
end;

{-- TMMCustomPanel ------------------------------------------------------------}
Procedure TMMCustomPanel.Changed;
begin
   Invalidate;
end;

{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.ScreenRect(aRect: TRect): TRect;
begin
   with aRect do
   begin
      Result.TopLeft := ClientToScreen(Point(Left,Top));
      Result.BottomRight := ClientToScreen(Point(Right,Bottom));
   end;
end;

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

{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.Paint;
Const
   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);

Var
   aRect: TRect;
   FontHeight: Integer;
   Text: PChar;

begin
     if assigned(FOnPaint) then FOnPaint(Self)
     else
     begin
        { draw the Bevel }
        aRect := FBevel.PaintBevel(Canvas, ClientRect, FFillBevel);
        with Canvas do
        begin
           if assigned(FOnFill) then FOnFill(Self,Canvas,aRect)
           else
           begin
              Brush.Color := Color;
              Brush.Style := bsSolid;
              FillRect(aRect);
           end;

           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 Alignments[Alignment]);
              finally
                 StrDispose(Text);
              end;
           end;
        end;
     end;
end;

{$IFNDEF BUILD_ACTIVEX}

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

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

   ControlStyle := ControlStyle + [csOpaque];

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

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

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

   inherited Destroy;
end;

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

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

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

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

{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.Changed;
begin
   Invalidate;
end;

{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.SetBevel(aValue: TMMBevel);
begin
   FBevel.Assign(aValue);
end;

{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.BevelExtend: Integer;
begin
   Result := 0;
   if (FBevel <> nil) then
       Result := FBevel.BevelExtend;
end;

{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.BeveledRect: TRect;
begin
   Result := Rect(0,0,Width,Height);
   InflateRect(Result, -BevelExtend, -BevelExtend);
end;

{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.ScreenRect(aRect: TRect): TRect;
begin
   with aRect do
   begin
      Result.TopLeft := ClientToScreen(Point(Left,Top));
      Result.BottomRight := ClientToScreen(Point(Right,Bottom));
   end;
end;

{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.SetTransparent(aValue: Boolean);
begin
   if (aValue <> FTransparent) then
   begin
      FTransparent := aValue;
      if FTransparent then ControlStyle := ControlStyle - [csOpaque]
      else ControlStyle := ControlStyle + [csOpaque];
      Refresh;
   end;
end;

{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.Paint;
Var
   aRect: TRect;

begin
   { draw the Bevel and fill the area }
   aRect := FBevel.PaintBevel(Canvas, ClientRect, True);

   if not FTransparent then
   with Canvas do
   begin
      Brush.Color := Color;
      Brush.Style := bsSolid;
      FillRect(aRect);
   end;
end;
{$ELSE}
{ TCommonDialog }

{== TMMCommonDialog ===========================================================}
constructor TMMCommonDialog.Create(aOwner: TComponent);
begin
  inherited Create(AOwner);
  FCtl3D := True;

  {$IFDEF BUILD_ACTIVEX}
  DesigningChanged(False);
  Visible := False;
  {$ENDIF}

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

{-- TMMCommonDialog -----------------------------------------------------------}
function TMMCommonDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
type
  TDialogFunc = function(var DialogData): Bool stdcall;
var
  ActiveWindow: HWnd;
  WindowList: Pointer;
begin
  ActiveWindow := GetActiveWindow;
  WindowList := DisableTaskWindows(0);
  try
    Result := TDialogFunc(DialogFunc)(DialogData);
  finally
    EnableTaskWindows(WindowList);
    SetActiveWindow(ActiveWindow);
  end;
end;
{$ENDIF}

{==============================================================================}
function DeviceIdToIdent(Id: LongInt; var S: string): Boolean;
begin
   Result := False;
   if Id = InvalidId then
      S := 'InvalidId'
   else if Id = MapperId then
      S := 'MapperId'
   else
      Exit;
   Result := True;
end;

{==============================================================================}
function IdentToDeviceId(const S: string; var Id: LongInt): Boolean;
begin
   Result := False;
   if CompareText(S,'InvalidId') = 0 then
      Id := InvalidId
   else if CompareText(S,'MapperId') = 0 then
      Id := MapperId
   else
      Exit;
   Result := True;
end;

{------------------------------------------------------------------------------}
procedure LoadCursors;
var
   i: integer;

begin
   for i := 1 to NumCursors do
       Screen.Cursors[crsBase+i]:= LoadResCursor(i);
end;

initialization
   LoadCursors;
   RegisterIntegerConsts(TypeInfo(TMMDeviceId),IdentToDeviceId,DeviceIdToIdent);
end.