extactns.pas

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

        Result := ActivePageIndex = PageCount - 1
    else
      with TTabControlClass(FTabControl) do
        Result := TabIndex = Tabs.Count - 1;
  end;

begin
  inherited UpdateTarget(Target);
  if not FWrap and FEnabled and (Length(FLastTabCaption) = 0) and OnLastTab then
    Enabled := False
  else
    Enabled := FEnabled;
  if not Enabled then exit;
  if not FWrap and OnLastTab then
  begin
    if (Caption <> FLastTabCaption) then
    begin
      FOldCaption := Caption;
      Caption := FLastTabCaption;
    end;
  end
  else
    if (Length(FOldCaption) > 0) and (AnsiCompareText(Caption, FOldCaption) <> 0) then
    begin
      Caption := FOldCaption;
      FOldCaption := ''
    end;
end;

{ TOpenPicture }

function TOpenPicture.GetDialog: TOpenPictureDialog;
begin
  Result := TOpenPictureDialog(FDialog);
end;

function TOpenPicture.Getdialogclass: TCommonDialogClass;
begin
  Result := TOpenPictureDialog;
end;

{ TSavePicture }

function TSavePicture.GetDialog: TSavePictureDialog;
begin
  Result := TSavePictureDialog(FDialog);
end;

function TSavePicture.Getdialogclass: TCommonDialogClass;
begin
  Result := TSavePictureDialog;
end;

{$IFDEF MSWINDOWS}
{ TURLAction }

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

procedure TURLAction.UpdateTarget(Target: TObject);
begin
  Enabled := (Length(FURL) > 0);
end;

{ TBrowseURL }

procedure TBrowseURL.ExecuteTarget(Target: TObject);
begin
  if Assigned(FBeforeBrowse) then
    FBeforeBrowse(Self);
  ShellExecute(0, nil, PChar(URL), '', '', SW_SHOWNORMAL);
  if Assigned(FAfterBrowse) then
    FAfterBrowse(Self);
end;
{$ENDIF}

{ TSendMail }

destructor TSendMail.Destroy;
begin
  if Assigned(FText) then
    FreeAndNil(FText);
  inherited Destroy;
end;

procedure TSendMail.ExecuteTarget(Target: TObject);
var
  MapiMessage: TMapiMessage;
  MError: Cardinal;
begin
  with MapiMessage do
  begin
    ulReserved := 0;
    lpszSubject := nil;
    lpszNoteText := PChar(Text.Text);
    lpszMessageType := nil;
    lpszDateReceived := nil;
    lpszConversationID := nil;
    flFlags := 0;
    lpOriginator := nil;
    nRecipCount := 0;
    lpRecips := nil;
    nFileCount := 0;
    lpFiles := nil;
  end;

  MError := MapiSendMail(0, Application.Handle, MapiMessage,
    MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0);
  if MError <> 0 then MessageDlg(SSendError, mtError, [mbOK], 0);
end;

function TSendMail.GetText: TStrings;
begin
  if FText = nil then
    FText := TStringList.Create;
  Result := FText;
end;

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

procedure TSendMail.SetText(const Value: TStrings);
begin
  if FText = nil then
    FText := TStringList.Create;
  FText.Assign(Value);
end;

procedure TSendMail.UpdateTarget(Target: TObject);
begin
  Enabled := True;
end;

{ TListControlAction }

constructor TListControlAction.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FListControl := nil;
end;

function TListControlAction.HandlesTarget(Target: TObject): Boolean;
begin
  Result := (ListControl <> nil) or
    (ListControl = nil) and (Target is TCustomListControl) and
    TCustomListControl(Target).Focused;
end;

type
  TCustomListControlType = class(TCustomListControl);
  TCustomMultiSelectListControlType = class(TCustomMultiSelectListControl);

function TListControlAction.IsEnabled(Target: TObject): Boolean;
var
  LC: TCustomListControlType;
begin
  if Target is TCustomListControl then
  begin
    LC := TCustomListControlType(Target);
    Result := (LC.GetCount > 0);
  end
  else
    Result := False;
end;

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

procedure TListControlAction.SetListControl(const Value: TCustomListControl);
begin
  if Value <> FListControl then
  begin
    FListControl := Value;
    if Value <> nil then Value.FreeNotification(Self);
  end;
end;

{ TListControlSelectAll }

procedure TListControlSelectAll.ExecuteTarget(Target: TObject);
begin
  TCustomListControl(Target).SelectAll;
end;

procedure TListControlSelectAll.UpdateTarget(Target: TObject);
var
  LC: TCustomMultiSelectListControlType;
begin
  if Target is TCustomMultiSelectListControl then
  begin
    LC := TCustomMultiSelectListControlType(Target);
    Enabled := inherited IsEnabled(Target) and LC.MultiSelect and
      (LC.GetCount > 0) and (LC.SelCount < LC.GetCount);
  end
  else
    Enabled := False;
end;

{ TListControlClearSelection }

procedure TListControlClearSelection.ExecuteTarget(Target: TObject);
begin
  TCustomListControl(Target).ClearSelection;
end;

procedure TListControlClearSelection.UpdateTarget(Target: TObject);
var
  LC: TCustomListControlType;
begin
  LC := TCustomListControlType(Target);
  if Target is TCustomMultiSelectListControl then
    Enabled := inherited IsEnabled(Target) and (LC.GetCount > 0) and
      (LC.ItemIndex <> -1) and (TCustomMultiSelectListControlType(LC).SelCount > 0)
  else
    Enabled := inherited IsEnabled(Target) and (LC.GetCount > 0) and
      (LC.ItemIndex <> -1);
end;

{ TListControlCopySelection }

procedure TListControlCopySelection.ExecuteTarget(Target: TObject);
begin
  ListControl.CopySelection(FDestination);
end;

function TListControlCopySelection.HandlesTarget(Target: TObject): Boolean;
begin
  Result := inherited HandlesTarget(Target) and Assigned(FDestination);
  if Result then
    if ListControl = nil then
      with Target as TCustomListControl do
        Result := ItemIndex <> -1
    else
      Result := ListControl.ItemIndex <> -1
end;

procedure TListControlCopySelection.SetDestination(
  const Value: TCustomListControl);
begin
  if Value <> FDestination then
  begin
    FDestination := Value;
    if Value <> nil then Value.FreeNotification(Self);
  end;
end;

procedure TListControlCopySelection.UpdateTarget(Target: TObject);
var
  LC: TCustomListControlType;
begin
  LC := TCustomListControlType(Target);
  if Target is TCustomMultiSelectListControl then
    Enabled := inherited IsEnabled(Target) and (LC.GetCount > 0) and
      (LC.ItemIndex >= 0) and (TCustomMultiSelectListControlType(LC).SelCount > 0)
  else
    Enabled := inherited IsEnabled(Target) and (LC.GetCount > 0) and
      (LC.ItemIndex >= 0) and (LC.ItemIndex >= 0);
end;

{ TListControlMoveSelection }

procedure TListControlMoveSelection.ExecuteTarget(Target: TObject);
begin
  TCustomListControl(Target).MoveSelection(FDestination);
end;

{ TListControlDeleteSelection }

procedure TListControlDeleteSelection.ExecuteTarget(Target: TObject);
begin
  TCustomListControl(Target).DeleteSelected;
end;

type
  TCustomListControlClass = class(TCustomListControl);

procedure TListControlDeleteSelection.UpdateTarget(Target: TObject);
begin
  Enabled := inherited IsEnabled(Target) and
    (TCustomListControl(Target).ItemIndex <> -1);
end;

{$IFDEF MSWINDOWS}
{ TDownLoadURL }

const
  // Maps to the status codes for IBindStatusCallBack
  BindStatusCode: array[0..54] of DWORD =
   (BINDSTATUS_FINDINGRESOURCE,
    BINDSTATUS_CONNECTING,
    BINDSTATUS_REDIRECTING,
    BINDSTATUS_BEGINDOWNLOADDATA,
    BINDSTATUS_DOWNLOADINGDATA,
    BINDSTATUS_ENDDOWNLOADDATA,
    BINDSTATUS_BEGINDOWNLOADCOMPONENTS,
    BINDSTATUS_INSTALLINGCOMPONENTS,
    BINDSTATUS_ENDDOWNLOADCOMPONENTS,
    BINDSTATUS_USINGCACHEDCOPY,
    BINDSTATUS_SENDINGREQUEST,
    BINDSTATUS_CLASSIDAVAILABLE,
    BINDSTATUS_MIMETYPEAVAILABLE,
    BINDSTATUS_CACHEFILENAMEAVAILABLE,
    BINDSTATUS_BEGINSYNCOPERATION,
    BINDSTATUS_ENDSYNCOPERATION,
    BINDSTATUS_BEGINUPLOADDATA,
    BINDSTATUS_UPLOADINGDATA,
    BINDSTATUS_ENDUPLOADDATA,
    BINDSTATUS_PROTOCOLCLASSID,
    BINDSTATUS_ENCODING,
    BINDSTATUS_VERIFIEDMIMETYPEAVAILABLE,
    BINDSTATUS_CLASSINSTALLLOCATION,
    BINDSTATUS_DECODING,
    BINDSTATUS_LOADINGMIMEHANDLER,
    BINDSTATUS_CONTENTDISPOSITIONATTACH,
    BINDSTATUS_FILTERREPORTMIMETYPE,
    BINDSTATUS_CLSIDCANINSTANTIATE,
    BINDSTATUS_IUNKNOWNAVAILABLE,
    BINDSTATUS_DIRECTBIND,
    BINDSTATUS_RAWMIMETYPE,
    BINDSTATUS_PROXYDETECTING,
    BINDSTATUS_ACCEPTRANGES,
    BINDSTATUS_CONTENTDISPOSITIONATTACH,
    BINDSTATUS_FILTERREPORTMIMETYPE,
    BINDSTATUS_CLSIDCANINSTANTIATE,
    BINDSTATUS_IUNKNOWNAVAILABLE,
    BINDSTATUS_DIRECTBIND,
    BINDSTATUS_RAWMIMETYPE,
    BINDSTATUS_PROXYDETECTING,
    BINDSTATUS_ACCEPTRANGES,
    BINDSTATUS_COOKIE_SENT,
    BINDSTATUS_COMPACT_POLICY_RECEIVED,
    BINDSTATUS_COOKIE_SUPPRESSED,
    BINDSTATUS_COOKIE_STATE_UNKNOWN,
    BINDSTATUS_COOKIE_STATE_ACCEPT,
    BINDSTATUS_COOKIE_STATE_REJECT,
    BINDSTATUS_COOKIE_STATE_PROMPT,
    BINDSTATUS_COOKIE_STATE_LEASH,
    BINDSTATUS_COOKIE_STATE_DOWNGRADE,
    BINDSTATUS_POLICY_HREF,
    BINDSTATUS_P3P_HEADER,
    BINDSTATUS_SESSION_COOKIE_RECEIVED,
    BINDSTATUS_PERSISTENT_COOKIE_RECEIVED,
    BINDSTATUS_SESSION_COOKIES_ALLOWED
    );

function DWordEnumToPascalEnumOrd(EnumArray: array of DWORD; Value: DWORD): Integer;
begin
  for Result := Low(EnumArray) to High(EnumArray) do
    if Value = EnumArray[Result] then Exit;
  raise Exception.CreateRes(@SInvalidEnumValue);
end;

type
  TUrlMonDownloadToFile = function(Caller: IUnknown; URL: PAnsiChar; FileName: PAnsiChar;
    Reserved: DWORD; StatusCB: IBindStatusCallback): HResult; stdcall;

var
  UrlMonHandle: HMODULE;
  UrlMonDownloadToFile: TUrlMonDownloadToFile;
  UrlMonInitialized: Boolean;

const
  UrlMonLib = 'URLMON.DLL';
  sURLMonDownloadToFileA = 'URLDownloadToFileA';

procedure TDownLoadURL.ExecuteTarget(Target: TObject);
begin
  if not UrlMonInitialized then
  begin
    UrlMonHandle := LoadLibrary(UrlMonLib);
    if UrlMonHandle <> 0 then
      UrlMonDownloadToFile := GetProcAddress(UrlMonHandle, PChar(sURLMonDownloadToFileA));
    UrlMonInitialized := True;
  end;
  if Assigned(UrlMonDownloadToFile) then
  begin
    if URLMonDownloadToFile(nil, PChar(URL), PChar(FileName), 0, Self as IBindStatusCallBack) <> S_OK then
      raise Exception.CreateResFmt(@SErrorDownloadingURL, [URL]);
  end else
    raise Exception.CreateResFmt(@SUrlMonDllMissing, [UrlMonLib]);
end;

function TDownLoadURL.GetBindInfo(out grfBINDF: Cardinal;
  var bindinfo: _tagBINDINFO): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TDownLoadURL.GetPriority(out nPriority): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TDownLoadURL.OnDataAvailable(grfBSCF, dwSize: Cardinal;
  formatetc: PFormatEtc; stgmed: PStgMedium): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TDownLoadURL.OnLowResource(reserved: Cardinal): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TDownLoadURL.OnObjectAvailable(const iid: TGUID;
  punk: IUnknown): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TDownLoadURL.OnProgress(ulProgress, ulProgressMax,
  ulStatusCode: Cardinal; szStatusText: PWideChar): HRESULT;
const
  ContinueDownload: array[Boolean] of Integer = (S_OK, E_ABORT);
var
  Cancel: Boolean;
begin
  Cancel := False;
  if Assigned(FOnDownloadProgress) then
    FOnDownloadProgress(Self, ulProgress, ulProgressMax,
      TURLDownloadStatus(DWordEnumToPascalEnumOrd(BindStatusCode, ulStatusCode)),
      Trim(WideCharToString(szStatusText)), Cancel);
  Result := ContinueDownload[Cancel];
end;

function TDownLoadURL.OnStartBinding(dwReserved: Cardinal;
  pib: IBinding): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TDownLoadURL.OnStopBinding(hresult: HRESULT;
  szError: PWideChar): HRESULT;
begin
  Result := E_NOTIMPL;
end;
{$ENDIF}

initialization
finalization
{$IFDEF MSWINDOWS}
  if UrlMonInitialized and (UrlMonHandle <> 0) then
    FreeLibrary(UrlMonHandle);
{$ENDIF}
end.