cdibfeatures.pas

Delphi控件

  finally
    Writer.Free;
  end;
end;

procedure TDIBFeatureItem.AssignTo(Dest: TPersistent);
begin
  if Dest is TDIBFeatureItem then
    with TDIBFeatureItem(Dest) do
    begin
      Enabled := Self.Enabled;
      FeatureClassName := Self.FeatureClassName;
      FDIBFeature.Assign(Self.FDIBFeature);
    end
  else
    inherited;
end;

{ TDIBFeatures }

function TDIBFeatures.Add: TDIBFeatureItem;
begin
  Result := TDIBFeatureItem(inherited Add);
end;

constructor TDIBFeatures.Create(AOwner: TComponent);
begin
  inherited Create(AOwner, TDIBFeatureItem);
  FOwner := AOwner;
end;

function TDIBFeatures.GetItem(Index: Integer): TDIBFeatureItem;
begin
  Result := TDIBFeatureItem(inherited GetItem(Index));
end;

procedure TDIBFeatures.Loaded;
var
  X: Integer;
begin
  for X := 0 to Count - 1 do Items[X].Loaded;
end;

procedure TDIBFeatures.SetItem(Index: Integer; Value: TDIBFeatureItem);
begin
  inherited SetItem(Index, Value);
end;

procedure TDIBFeatures.Update(Item: TCollectionItem);
begin
  inherited Update(Item);
end;

procedure TDIBFeatures.WndProc(var Message: TMessage;
  var Handled: Boolean);
var
  X: Integer;
begin
  for X := 0 to Count - 1 do 
  begin
    with Items[X] do
      WndProc(Message, Handled);
    if Handled then break;
  end;
end;

{ TMoveableDIB }

procedure TMoveableDIB.AssignTo(Dest: TPersistent);
begin
  if Dest is TMoveableDIB then
    with TMoveableDIB(Dest) do
    begin
      AllowHorizontal := Self.AllowHorizontal;
      AllowVertical := Self.AllowVertical;
      BorderSize := Self.BorderSize;
      MouseButtons := Self.MouseButtons;
      SnapSize := Self.SnapSize;
    end;
  inherited;
end;

constructor TMoveableDIB.Create(AOwner: TComponent);
begin
  inherited;
  AllowVertical := True;
  AllowHorizontal := True;
  SnapSize := 1;
  MouseButtons := [mbLeft];
end;

procedure TMoveableDIB.DoKeyDown(Message: TWMKey);
begin
  with Message, Control do 
  begin
    case CharCode of
      VK_UP: if AllowVertical then Top := Top - SnapSize;
      VK_DOWN: if AllowVertical then Top := Top + SnapSize;
      VK_Left: if AllowHorizontal then Left := Left - SnapSize;
      VK_RIGHT: if AllowHorizontal then Left := Left + SnapSize;
    end;
  end;
end;

procedure TMoveableDIB.DoMouseDown(Message: TMessage);
begin
  if Control = nil then exit;
  with TWMMouse(Message) do 
  begin
    if ((FX >= BorderSize) or
      (FX <= Control.Width - BorderSize)) and
      ((FY >= BorderSize) or
      (FY <= Control.Height - BorderSize)) then
    begin
      FMoving := True;
      FX := XPos;
      FY := YPos;
    end;
  end;
  with Control do 
  begin
    FOrigX := Left;
    FOrigY := Top;
  end;
end;

procedure TMoveableDIB.DoMouseMove(Message: TMessage);
var
  DX, DY: Integer;
begin
  if FMoving then with TWMMouse(Message) do 
    begin
      if AllowHorizontal then
        DX := (XPos - FX)
      else
        DX := 0;
      if AllowVertical then
        DY := (YPos - FY)
      else
        DY := 0;
      if SnapSize > 1 then 
      begin
        DX := DX div SnapSize * SnapSize;
        DY := DY div SnapSize * SnapSize;
      end;
      if Control <> nil then with Control do 
        begin
          SetBounds(Left + DX, Top + DY, Width, Height);
        end;
    end;
end;

procedure TMoveableDIB.DoMouseUp;
begin
  FMoving := False;
end;

class function TMoveableDIB.GetDisplayName: string;
begin
  Result := 'Moveable DIB';
end;

procedure TMoveableDIB.WndProc(var Message: TMessage;
  var Handled: Boolean);
begin
  if Message.Msg = WM_KeyDown then DoKeyDown(TWMKey(Message));
  if FMoving then
    case Message.Msg of
      WM_MouseMove: DoMouseMove(Message);
      WM_RButtonUp: if FMouseButton = mbRight then DoMouseUp;
      WM_LButtonUp: if FMouseButton = mbLeft then DoMouseUp;
      WM_MButtonUp: if FMouseButton = mbMiddle then DoMouseUp;
    end
  else if (Message.Msg = WM_LButtonDown) or (Message.Msg = WM_MButtonDown) or
    (Message.Msg = WM_RButtonDown) then
  begin
    case Message.Msg of
      WM_LButtonDown: FMouseButton := mbLeft;
      WM_MButtonDown: FMouseButton := mbMiddle;
      WM_RButtonDown: FMouseButton := mbRight;
    end;
    if FMouseButton in MouseButtons then DoMouseDown(Message);
  end;
end;
{ TDIBFeature }

procedure TDIBFeature.AssignTo(Dest: TPersistent);
begin
  if not (Dest is TDIBFeature) then inherited;
end;

class function TDIBFeature.CanApplyTo(aComponent: TPersistent): Boolean;
begin
  Result := True;
end;

class function TDIBFeature.GetDisplayName: string;
begin
  Result := 'Unknown feature';
end;

function TDIBFeature.GetOwner: TPersistent;
begin
  Result := FControl;
end;

{ THighlightDIB }

procedure THighlightDIB.AssignTo(Dest: TPersistent);
begin
  if Dest is THighlightDIB then
    with THighlightDIB(Dest) do
    begin
      HighlightOpacity := Self.HighlightOpacity;
    end;
  inherited;
end;

class function THighlightDIB.CanApplyTo(aComponent: TPersistent): Boolean;
begin
  Result := (aComponent is TCustomDIBControl);
end;

constructor THighlightDIB.Create(AOwner: TComponent);
begin
  inherited;
  FHighlightOpacity := 255;
end;

class function THighlightDIB.GetDisplayName: string;
begin
  Result := 'Highlight dib';
end;

procedure THighlightDIB.WndProc(var Message: TMessage;
  var Handled: Boolean);
begin
  if Control is TCustomDIBControl then with THackDIBControl(Control) do 
    begin
      case Message.Msg of
        WM_SetFocus: if not Focused and not MouseInControl then
          begin
            FOrigOpacity := Opacity;
            Opacity := HighlightOpacity;
          end;

        WM_KillFocus: if Focused and not MouseInControl then
          begin
            Opacity := FOrigOpacity;
          end;

        CM_MouseEnter: if not Focused then
          begin
            if MouseCapture then exit;
            FOrigOpacity := Opacity;
            Opacity := HighlightOpacity;
          end;

        WM_LButtonUp:
          begin
            MouseCapture := False;
          end;

        CM_MouseLeave: if not Focused then
          begin
            if MouseCapture then exit;
            Opacity := FOrigOpacity;
          end;
      end;
    end;
end;


{ TControlItem }

procedure TControlItem.AssignTo(Dest: TPersistent);
begin
  if Dest is TControlItem then
    TControlItem(Dest).Control := FControl
  else
    inherited;
end;

function TControlItem.GetDisplayName: string;
begin
  if Control = nil then
    Result := inherited GetDisplayName
  else if Control.Name <> '' then
    Result := Control.Name
  else if Control.ClassName <> '' then
    Result := Control.ClassName
  else
    Result := inherited GetDisplayName;
end;

procedure TControlItem.SetControl(const Value: TControl);
var
  X: Integer;
begin
  if Value = nil then
    raise EFeatureError.Create('You cannot set Control to nil');
  for X := 0 to Collection.Count - 1 do
    if (TControlList(Collection).Items[X].Control = Value) and
      (Collection.Items[X] <> Self) then
      raise EFeatureError.Create('Control already exists in list.');
  FControl := Value;
end;

{ TShapeableDIB }

procedure TShapeableDIB.AssignTo(Dest: TPersistent);
begin
  if Dest is TShapeableDIB then
    with TShapeableDIB(Dest) do
    begin
      TransparentColor := Self.TransparentColor;
      TransparentMode := Self.TransparentMode;
      MaskLevel := Self.MaskLevel;
    end;
  inherited;
end;

procedure TShapeableDIB.CalculateRegion;
var
  CurrentView: TWinDIB;
  TransCol: TColor;
begin
  CurrentView := TWinDIB.Create(Control.Width, Control.Height);
  try
    CurrentView.QuickFill($00000000);
    THackDIBControl(Control).ControlDIB := CurrentView;
    THackDIBControl(Control).Paint;
    if FRegion <> 0 then DeleteObject(FRegion);
    if MaskLevel > 0 then
      FRegion := CurrentView.MakeRGN(MaskLevel)
    else
    begin
      if TransparentMode = tmAuto then
        TransCol := CurrentView.Canvas.Pixels[0, Control.Height - 1]
      else
        TransCol := TransparentColor;
      FRegion := CurrentView.MakeRGNFromColor(TransCol);
    end;
    FControlInvalidateTime := THackDIBControl(Control).LastInvalidateTime;
  finally
    CurrentView.Free;
    THackDIBControl(Control).ControlDIB := nil;
  end;
end;

class function TShapeableDIB.CanApplyTo(aComponent: TPersistent): Boolean;
begin
  Result := AComponent is TCustomDIBControl;
end;

constructor TShapeableDIB.Create(AOwner: TComponent);
begin
  inherited;
  FControlInvalidateTime := 1234;
  FRegion := 0;
end;

destructor TShapeableDIB.Destroy;
begin
  if FRegion <> 0 then DeleteObject(FRegion);
  inherited;
end;

class function TShapeableDIB.GetDisplayName: string;
begin
  Result := 'Shapeable DIB';
end;

procedure TShapeableDIB.WndProc(var Message: TMessage;
  var Handled: Boolean);
begin
  case Message.Msg of
    CM_HITTEST:
      begin
        Handled := True;
        if FControlInvalidateTime <> THackDIBControl(Control).LastInvalidateTime then
          CalculateRegion;
        with TCMHITTEST(Message) do
          if (FRegion = 0) or (PtInRegion(FRegion, XPos, YPos)) then
            Message.Result := HTCLIENT
        else
          Message.Result := HTNOWHERE;
      end;
  end;
end;

initialization
  RegisterDIBFeature(TMoveableDIB);
  RegisterDIBFeature(THighlightDIB);
  RegisterDIBFeature(TShapeableDIB);
end.