extactns.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

    property Caption;
    property Enabled;
    property HelpContext;
    property HelpKeyword;
    property HelpType;
    property Hint;
    property ImageIndex;
    property ListControl;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnHint;
  end;

{ TListControlClearSelection }

  TListControlClearSelection = class(TListControlAction)
  public
    procedure ExecuteTarget(Target: TObject); override;
    procedure UpdateTarget(Target: TObject); override;
  published
    property Caption;
    property Enabled;
    property HelpContext;
    property HelpKeyword;
    property HelpType;
    property Hint;
    property ImageIndex;
    property ListControl;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnHint;
  end;

{ TListControlDeleteSelection }

  TListControlDeleteSelection = class(TListControlAction)
  public
    procedure ExecuteTarget(Target: TObject); override;
    procedure UpdateTarget(Target: TObject); override;
  published
    property Caption;
    property Enabled;
    property HelpContext;
    property HelpKeyword;
    property HelpType;
    property Hint;
    property ImageIndex;
    property ListControl;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnHint;
  end;

{ TListBoxCopySelection }

  TListControlCopySelection = class(TListControlAction)
  private
    FDestination: TCustomListControl;
    procedure SetDestination(const Value: TCustomListControl);
  public
    procedure ExecuteTarget(Target: TObject); override;
    function HandlesTarget(Target: TObject): Boolean; override;
    procedure UpdateTarget(Target: TObject); override;
  published
    property Caption;
    property Destination: TCustomListControl read FDestination write SetDestination;
    property Enabled;
    property HelpContext;
    property HelpKeyword;
    property HelpType;
    property Hint;
    property ImageIndex;
    property ListControl;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnHint;
  end;

{ TListControlMoveSelection }

  TListControlMoveSelection = class(TListControlCopySelection)
  public
    procedure ExecuteTarget(Target: TObject); override;
  end;

implementation

uses Forms, Consts, commctrl, Mapi;

{ TCustomFileRun }

constructor TCustomFileRun.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBrowse := False;
  FHinst := 0;
  FParentHWnd := 0;
  FOperation := 'open';
  FFile := '';
  FParameters := '';
  FDirectory := '';
  FShowCmd := scShowNormal;
  SetupBrowseDialog;
end;

procedure TCustomFileRun.ExecuteTarget(Target: TObject);
const
  ShowCmds: array[TShowCmd] of Integer = (SW_HIDE, SW_MAXIMIZE, SW_MINIMIZE,
    SW_RESTORE, SW_SHOW, SW_SHOWDEFAULT, SW_SHOWMAXIMIZED, SW_SHOWMINIMIZED,
    SW_SHOWMINNOACTIVE, SW_SHOWNA, SW_SHOWNOACTIVATE, SW_SHOWNORMAL);
var
  ParentHWnd: THandle;
begin
  if Assigned(FParentControl) then
  begin
    if FParentControl.HandleAllocated then
      ParentHwnd := FParentControl.Handle
    else
      ParentHWnd := 0;
  end
  else
    if IsWindow(FParentHWnd) then
      ParentHwnd := FParentHWnd
    else
      ParentHWnd := 0;
  if FBrowse then
  begin
    if FBrowseDlg.Execute then
      FHInst := ShellExecute(ParentHWnd, PChar(FOperation),
        PChar(FBrowseDlg.FileName), PChar(FParameters), PChar(FDirectory),
        ShowCmds[FShowCmd])
    else
      exit;
  end
  else
    FHInst := ShellExecute(ParentHWnd, PChar(FOperation), PChar(FFile),
      PChar(FParameters), PChar(FDirectory), ShowCmds[FShowCmd]);
  if FHInst <= 32 then
    raise Exception.Create(SysErrorMessage(FHinst));
end;

function TCustomFileRun.HandlesTarget(Target: TObject): Boolean;
begin
  Result := True;
end;

procedure TCustomFileRun.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FParentControl) then
    FParentControl := nil;
end;

procedure TCustomFileRun.SetBrowseDlg(const Value: TOpenDialog);
begin
  if Value <> FBrowseDlg then
  begin
    if Value = nil then
      SetupBrowseDialog
    else
    begin
      if FBrowseDlg.Owner = Self then
        FreeAndNil(FBrowseDlg);
      FBrowseDlg := Value;
    end;
  end;
end;

procedure TCustomFileRun.SetParentControl(const Value: TWinControl);
begin
  if FParentControl <> Value then
  begin
    FParentControl := Value;
    FParentControl.FreeNotification(Self);
  end;
end;

procedure TCustomFileRun.SetupBrowseDialog;
begin
  FBrowseDlg := TOpenDialog.Create(Self);
  FBrowseDlg.Name := Copy(TOpenDialog.ClassName, 2, Length(TOpenDialog.ClassName));
  FBrowseDlg.SetSubComponent(True);
  FBrowseDlg.Title := SFileRunDialogTitle;
  FBrowseDlg.Name := 'FileRunBrowseDlg';  { do not localize }
end;

procedure TCustomFileRun.UpdateTarget(Target: TObject);
begin
  Enabled := FBrowse or (not FBrowse and (Length(FileName) > 0));
end;

{ TRichEditAction }

constructor TRichEditAction.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AutoCheck := True;
end;

function TRichEditAction.CurrText(Edit: TCustomRichEdit): TTextAttributes;
begin
  Result := Edit.SelAttributes;
end;

function TRichEditAction.HandlesTarget(Target: TObject): Boolean;
begin
  Result := ((Control <> nil) and (Target = Control) or
    (Control = nil) and (Target is TCustomRichEdit)) and TCustomEdit(Target).Focused;
end;

procedure TRichEditAction.SetFontStyle(Edit: TCustomRichEdit; Style: TFontStyle);
begin
  if Edit = nil then exit;
  if Style in CurrText(Edit).Style then
    CurrText(Edit).Style := CurrText(Edit).Style - [Style]
  else
    CurrText(Edit).Style := CurrText(Edit).Style + [Style];
end;

{ TRichEditBold }

procedure TRichEditBold.ExecuteTarget(Target: TObject);
begin
  SetFontStyle(Target as TCustomRichEdit, fsBold);
end;

procedure TRichEditBold.UpdateTarget(Target: TObject);
begin
  inherited UpdateTarget(Target);
  Enabled := Target is TCustomRichEdit;
  Checked := fsBold in TCustomRichEdit(Target).SelAttributes.Style;
end;

{ TRichEditItalic }

procedure TRichEditItalic.ExecuteTarget(Target: TObject);
begin
  SetFontStyle(Target as TCustomRichEdit, fsItalic);
end;

procedure TRichEditItalic.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  Checked := fsItalic in TCustomRichEdit(Target).SelAttributes.Style;
end;

{ TRichEditUnderline }

procedure TRichEditUnderline.ExecuteTarget(Target: TObject);
begin
  SetFontStyle(Target as TCustomRichEdit, fsUnderline);
end;

procedure TRichEditUnderline.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  Checked := fsUnderline in TCustomRichEdit(Target).SelAttributes.Style;
end;

{ TRichEditStrikeOut }

procedure TRichEditStrikeOut.ExecuteTarget(Target: TObject);
begin
  if Target is TCustomRichEdit then
    SetFontStyle(Target as TCustomRichEdit, fsStrikeOut);
end;

procedure TRichEditStrikeOut.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  if Target is TCustomRichEdit then
    Checked := fsStrikeOut in TCustomRichEdit(Target).SelAttributes.Style;
end;

{ TRichEditBullets }

procedure TRichEditBullets.ExecuteTarget(Target: TObject);
begin
  if Target is TCustomRichEdit then
    if TCustomRichEdit(Target).Paragraph.Numbering = nsNone then
      TCustomRichEdit(Target).Paragraph.Numbering := nsBullet
    else
      TCustomRichEdit(Target).Paragraph.Numbering := nsNone;
end;

procedure TRichEditBullets.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  Checked := Enabled and (TCustomRichEdit(Target).Paragraph.Numbering = nsBullet);
end;

{ TRichEditAlignLeft }

procedure TRichEditAlignLeft.ExecuteTarget(Target: TObject);
begin
  if Target is TCustomRichEdit then
    TCustomRichEdit(Target).Paragraph.Alignment := taLeftJustify;
  Checked := True;
end;

procedure TRichEditAlignLeft.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  Checked := Enabled and (TCustomRichEdit(Target).Paragraph.Alignment = taLeftJustify);
end;

{ TRichEditAlignRight }

procedure TRichEditAlignRight.ExecuteTarget(Target: TObject);
begin
  if Target is TCustomRichEdit then
    TCustomRichEdit(Target).Paragraph.Alignment := taRightJustify;
  Checked := True;
end;

procedure TRichEditAlignRight.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  Checked := Enabled and (TCustomRichEdit(Target).Paragraph.Alignment = taRightJustify);
end;

{ TRichEditAlignCenter }

procedure TRichEditAlignCenter.ExecuteTarget(Target: TObject);
begin
  if Target is TCustomRichEdit then
    TCustomRichEdit(Target).Paragraph.Alignment := taCenter;
  Checked := True;
end;

procedure TRichEditAlignCenter.UpdateTarget(Target: TObject);
begin
  Enabled := Target is TCustomRichEdit;
  Checked := Enabled and (TCustomRichEdit(Target).Paragraph.Alignment = taCenter);
end;

{ TTabAction }

constructor TTabAction.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DisableIfNoHandler := False;
  Enabled := csDesigning in ComponentState;
  FSkipHiddenTabs := True;
end;

function TTabAction.HandlesTarget(Target: TObject): Boolean;
begin
  Result := Assigned(FTabControl);
end;

procedure TTabAction.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FTabControl) then
    FTabControl := nil;
end;

type
  TTabControlClass = class(TCustomTabControl);

procedure TTabAction.UpdateTarget(Target: TObject);
begin
  if FTabControl is TPageControl then
    FEnabled := Assigned(FTabControl) and FTabControl.Enabled and
      (TPageControl(FTabControl).PageCount > 0)
  else
    FEnabled := Assigned(FTabControl) and FTabControl.Enabled and
      (TTabControlClass(FTabControl).Tabs.Count > 0);
  if FEnabled and Assigned(FOnValidateTab) then
    FOnValidateTab(Self, FTabControl, FEnabled);
end;

procedure TTabAction.SelectNextTab(GoForward: Boolean = True);
const
  Direction: array[Boolean] of Integer = (-1, 1);
begin
  if Assigned(FBeforeTabChange) then
    FBeforeTabChange(Self);
  if FTabControl is TPageControl then
  begin
    with FTabControl as TPageControl do
      if Wrap and GoForward and (ActivePageIndex = PageCount - 1) then
        ActivePageIndex := 0
      else if Wrap and not GoForward and (ActivePageIndex = 0) then
        ActivePageIndex := PageCount - 1
      else
        SelectNextPage(GoForward, FSkipHiddenTabs);
  end
  else if FTabControl is TCustomTabControl then
    with TTabControlClass(FTabControl) do
      if Wrap and GoForward and (TabIndex = Tabs.Count - 1) then
        TabIndex := 0
      else if Wrap and not GoForward and (TabIndex = 0) then
        TabIndex := Tabs.Count - 1
      else
        TabIndex := TabIndex + Direction[GoForward];
  if Assigned(FAfterTabChange) then
    FAfterTabChange(Self);
end;

{ TPreviousTab }

procedure TPreviousTab.ExecuteTarget(Target: TObject);
begin
  SelectNextTab(False)
end;

procedure TPreviousTab.UpdateTarget(Target: TObject);
begin
  inherited UpdateTarget(Target);
  if FEnabled then
  begin
    if FWrap then
      Enabled := True
    else
      if FTabControl is TPageControl then
        Enabled := (TPageControl(FTabControl).ActivePageIndex > 0)
      else
        Enabled := (TTabControlClass(FTabControl).TabIndex > 0);
  end;
end;

{ TNextTab }

procedure TNextTab.ExecuteTarget(Target: TObject);

  function NextPage: Boolean;
  begin
    if FTabControl is TPageControl then
      with TPageControl(FTabControl) do
        Result := ActivePageIndex < PageCount - 1
    else
      with TTabControlClass(FTabControl) do
        Result := TabIndex < Tabs.Count - 1;
  end;

begin
  if NextPage or FWrap then
    SelectNextTab
  else
    if (Length(FLastTabCaption) > 0) and Assigned(FOnFinish) then
      FOnFinish(Self);
end;

procedure TNextTab.UpdateTarget(Target: TObject);

  function OnLastTab: Boolean;
  begin
    if FTabControl is TPageControl then
      with TPageControl(FTabControl) do