oledlgs.pas

是一个delphi的流程制作软件

function TOleBusyDialog.RetryRejectedCall (Task : HTASK; TickCount : integer) : integer;
begin
  if TickCount < FInitial then
    Result := FRetry else
  begin
    FTask := Task;
    if Execute then
      Result := FRepeat
    else
      Result := -1
  end
end;

// Execute the OleUIBusy dialog by filling the the structure and calling
// the standard function.
function TOleBusyDialog.Execute : boolean;
var
  Bz : TOleUIBusy;
begin
  InitExecute (Bz, sizeof (TOleUIBusy));
// Server task number
  Bz.Task := FTask;
// Set up Flags
  if oboDisableCancel in FOptions then
    Bz.dwFlags := Bz.dwFlags or BZ_DISABLECANCELBUTTON;
  if oboDisableRetry in FOptions then
    Bz.dwFlags := Bz.dwFlags or BZ_DISABLERETRYBUTTON;
  if oboNotResponding in FOptions then
    Bz.dwFlags := Bz.dwFlags or BZ_NOTRESPONDINGDIALOG;

// Returns True on Retry, False on Cancel
  FReturned := OleUIBusy (Bz);
  Result := OleUICheck (FReturned, otBusy) <> OLEUI_CANCEL
end;

//=== BUSY DIALOG EXTENDED =====================================================
// This busy dialog uses the hook function to change the text in the message,
// Retry or Cancel buttons.  The icon can be changed as well.
// The hook function is therefore not available to the user. Use the Event instead.

function OleDialogHookBusyEx (Wnd : HWnd; Msg, WParam, LParam : Longint): Longint stdcall;
const
  IDC_BZ_CANCEL = 2;
begin
  if Msg = WM_INITDIALOG then
    with TOleBusyDialogEx (LParam) do
    begin
      if FRetryText <> '' then
        SetDlgItemText (Wnd, IDC_BZ_RETRY, PChar (FRetryText));
      if FCancel <> '' then
        SetDlgItemText (Wnd, IDC_BZ_CANCEL, PChar (FCancel));
      if FText <> '' then
        SetDlgItemText (Wnd, IDC_BZ_MESSAGE1, PChar (FText));
      if not FIcon.Empty then
        SendDlgItemMessage (Wnd, IDC_BZ_ICON, STM_SETICON, FIcon.Handle, 0)
    end;

  Result := OleDialogHook (Wnd, Msg, WParam, LParam)
end;

constructor TOleBusyDialogEx.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FIcon := TIcon.Create;
  FHook := OleDialogHookBusyEx
end;

destructor TOleBusyDialogEx.Destroy;
begin
  FIcon.Free;
  inherited Destroy
end;

procedure TOleBusyDialogEx.SetIcon (Value : TIcon);
begin
  FIcon.Assign (Value)
end;

//=== Ole UI Paste Special Dialog ==============================================

constructor TPasteEntryItem.Create (Collection: TCollection);
begin
  inherited Create (Collection);
  Name := 'Text';
  Medium := [cmGlobal];
  Aspect := caContent;
  FText := '%s';
  FResult := '%s'
end;

procedure TPasteEntryItem.SetName (const Value : TClipName);
begin
  if FName <> Value then
  begin
    FName := Value;
    FFormat := GetPredefinedFormat (Value);
    if FFormat = 0 then
      FFormat := RegisterClipboardFormat (PChar(Value))
  end
end;

procedure TPasteEntryItem.SetFormat (const Value : TClipFormat);
begin
  if FFormat <> Value then
  begin
    FFormat := Value;
    FName := GetClipboardFormatName (Value)
  end
end;

procedure TPasteEntryItem.Assign (Source: TPersistent);
var
  Item : TPasteEntryItem;
begin
  if Source is TPasteEntryItem then
  begin
    Item := TPasteEntryItem (Source);
    Name := Item.Name;
    Aspect := Item.Aspect;
    Medium := Item.Medium;
    Text := Item.Text;
    Options := Item.Options;
    Result := Item.Result
  end else
    inherited Assign (Source)
end;

function TPasteEntryItem.GetDisplayName: string;
begin
  Result := Name;
  if Result = '' then
    Result := inherited GetDisplayName
end;

//--- TPasteEntryList

constructor TPasteEntryList.Create(AOwner: TComponent);
begin
  inherited Create (TPasteEntryItem);
  FOwner := AOwner
end;

function TPasteEntryList.GetItem (Index: Integer): TPasteEntryItem;
begin
  Result := TPasteEntryItem (inherited GetItem(Index))
end;

procedure TPasteEntryList.SetItem(Index: Integer; Value: TPasteEntryItem);
begin
  inherited SetItem (Index, Value)
end;

function TPasteEntryList.Add: TPasteEntryItem;
begin
  Result := TPasteEntryItem (inherited Add)
end;

function TPasteEntryList.GetOwner : TPersistent;
begin
  Result := FOwner
end;

//=== PASTE SPECIAL DIALOG =====================================================

constructor TOlePasteSpecialDialog.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FFormats := TPasteEntryList.Create (Self);
  FExclude := TStringList.Create;
  FLinkTypes := TStringList.Create;
  FMetafile := TUIMetafile.Create;
  FSelectPaste := true
end;

destructor TOlePasteSpecialDialog.Destroy;
begin
  FFormats.Free;
  FExclude.Free;
  FLinkTypes.Free;
  FMetafile.Free;
  inherited Destroy
end;

function TOlePasteSpecialDialog.GetSelected : TPasteEntryItem;
begin
  Result := FFormats [FSelIndex]
end;

procedure TOlePasteSpecialDialog.SetExclude (Value : TStrings);
begin
  FExclude.Assign (Value)
end;

procedure TOlePasteSpecialDialog.SetLinkTypes (Value : TStrings);
begin
  FLinkTypes.Assign (Value)
end;

function TOlePasteSpecialDialog.Execute : boolean;
var
  Ps  : TOleUIPasteSpecial;
  Pea : PPasteEntryArray;
  Pca : PCLSIDArray;
  PcaSize,
  PeaSize,
  Loop : integer;
  Links : array [0..7] of integer;
begin
  InitExecute (Ps, sizeof (TOleUIPasteSpecial));
// Put the DataObject in (can be nil)
  Ps.lpSrcDataObj := FDataObject;
// Put in main flags
  if FShowHelp then
    Ps.dwFlags := Ps.dwFlags or PSF_SHOWHELP;
  if FSelectPaste then
    Ps.dwFlags := Ps.dwFlags or PSF_SELECTPASTE;
  if FSelectPasteLink then
    Ps.dwFlags := Ps.dwFlags or PSF_SELECTPASTELINK;
  if FDisableDisplayAsIcon then
    Ps.dwFlags := Ps.dwFlags or PSF_DISABLEDISPLAYASICON;
  if FHideChangeIcon then
    Ps.dwFlags := Ps.dwFlags or PSF_HIDECHANGEICON;
  if FStayOnClipboardChange then
    Ps.dwFlags := Ps.dwFlags or PSF_STAYONCLIPBOARDCHANGE;
  if FNoRefreshDataObject then
    Ps.dwFlags := Ps.dwFlags or PSF_NOREFRESHDATAOBJECT;

// Fill linktypes array
  for Loop := 0 to FLinkTypes.Count - 1 do
    Links [Loop] := GetClipboardFormat (FLinkTypes[Loop]);
  Ps.arrLinkTypes := @Links;
  Ps.cLinkTypes := FLinkTypes.Count;

// Fill CLSID exclusions
  Pca := MakeCLSIDArray (FExclude, PcaSize);
  Ps.lpClsidExclude := pointer (Pca);
  Ps.cClsidExclude := FExclude.Count;

// Fill allowed formats array

  Pea := MakePasteEntriesArray (FFormats, PeaSize);
  Ps.cPasteEntries := FFormats.Count;
  Ps.arrPasteEntries := pointer (Pea);

  try
// Run the dialog
    FReturned := OLEUIPasteSpecial (Ps);
    Result := OleUICheck (FReturned, otPasteSpecial) = OLEUI_OK;

// if Ok the obtain out data
    if Result then
    begin
      FLink := Ps.fLink;
      FDataObject := Ps.lpSrcDataObj;
      FSelIndex := Ps.nSelectedIndex;
      FSelectPaste := Ps.dwFlags and PSF_SELECTPASTE <> 0;
      FSelectPasteLink := Ps.dwFlags and PSF_SELECTPASTELINK <> 0;
      FCheckDisplayAsIcon := Ps.dwFlags and PSF_CHECKDISPLAYASICON <> 0;
      FMetafile.MetaPict :=  Ps.hMetaPict;
      FSize.X := Ps.Sizel.cx;
      FSize.Y := Ps.Sizel.cy
    end
  finally
    FreeMetafilePict (Ps.hMetaPict);
    if Assigned (Pca) then
      FreeMem (Pca, PcaSize);
    if Assigned (Pea) then
      FreeMem (Pea, PeaSize)
  end;
end;

function OleDialogHookPasteSpecialEx (Wnd : HWnd; Msg, WParam, LParam : Longint): Longint stdcall;
begin
  if Msg = WM_INITDIALOG then
    with TOlePasteSpecialDialogEx (LParam) do
    begin
      if FResult <> '' then
        SetDlgItemText (Wnd, IDC_PS_RESULTTEXT, PChar (FResult));
      if FSource <> '' then
        SetDlgItemText (Wnd, IDC_PS_SOURCETEXT, PChar (FSource))
    end;
// chain to base dialog hook proc
  Result := OleDialogHook (Wnd, Msg, WParam, LParam)
end;

constructor TOlePasteSpecialDialogEx.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FHook := OleDialogHookPasteSpecialEx
end;

//--- OleChangeIconDialog ------------------------------------------------------

constructor TOleChangeIconDialog.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FMetafile := TUIMetafile.Create
end;

destructor TOleChangeIconDialog.Destroy;
begin
  FMetafile.Free;
  inherited Destroy
end;

function TOleChangeIconDialog.Execute : boolean;
var
  Ci : TOleUIChangeIcon;
begin
  InitExecute (Ci, sizeof (TOleUIChangeIcon));

  case FSelect of
    ciCurrent  : Ci.dwFlags := CIF_SELECTCURRENT;
    ciDefault  : Ci.dwFlags := CIF_SELECTDEFAULT;
    ciFromFile : Ci.dwFlags := CIF_SELECTFROMFILE
  end;
  if FShowHelp then
    Ci.dwFlags := Ci.dwFlags or CIF_SHOWHELP;
  if FUseExe then
    Ci.dwFlags := Ci.dwFlags or CIF_USEICONEXE;

  if FCLSID <> '' then
    Ci.CLSID := OleStdStringToCLSID (FCLSID);
  if FFilename <> '' then
  begin
    StrCopy (Ci.szIconExe, PChar (FFilename));
    Ci.cchIconExe := length (FFilename)
  end;
  if not FMetafile.Empty then
    Ci.hMetaPict := FMetafile.MetaPict;

  try
    FReturned := OleUIChangeIcon (Ci);
    Result := OleUICheck (FReturned, otChangeIcon) = OLEUI_OK;

    if Result then
    begin
      FMetafile.MetaPict := Ci.hMetaPict;
      if Ci.dwFlags and CIF_SELECTCURRENT <> 0 then
        FSelect := ciCurrent
      else
        if Ci.dwFlags and CIF_SELECTDEFAULT <> 0 then
          FSelect := ciDefault
        else
          FSelect := ciFromFile // because Ci.dwFlags = CIF_SELECTFROMFILE
    end
  finally
    FreeMetafilePict (Ci.hMetaPict)
  end
end;

function TOleChangeIconDialog.GetAsCLSID : TCLSID;
begin
  if FCLSID <> '' then
    Result := OleStdStringToCLSID (FCLSID)
  else
    Result := CLSID_NULL
end;

procedure TOleChangeIconDialog.SetAsCLSID (Value : TCLSID);
begin
  FCLSID := OleStdCLSIDToString (Value)
end;

procedure TOleChangeIconDialog.SetMetafile (Value : TUIMetafile);
begin
  FMetafile.Assign (Value)
end;

function TOleChangeIconDialog.StoreMetafile : boolean;
begin
  Result := FMetafile.Handle <> 0
end;

//--- OLE UI INSERT OBJECT -----------------------------------------------------

procedure TOleInsertObjectDialog.SetExclude (Value : TStrings);
begin
  FExclude.Assign (Value)
end;

constructor TOleInsertObjectDialog.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FMetafile := TUIMetafile.Create;
  FFormatEtc := TInsertObjectFormat.Create;
  FExclude := TStringList.Create;
  FRender := orDraw;
  FCreateNewObject := true;
  FCreateFileObject := true;
  FCreateLinkObject := true;
  FSelectCreateNew := true;
  FVerifyServersExist := true
end;

destructor TOleInsertObjectDialog.Destroy;
begin
  FStorage := nil;
  FClientSite := nil;//@@?
  FMetafile.Free;
  FExclude.Free;
  FFormatEtc.Free;
  inherited Destroy
end;

function TOleInsertObjectDialog.Execute : boolean;
var
  Io : TOleUIInsertObject;
  Pca : PCLSIDArray;
  PcaSize : integer;
  FormatEtc : TFormatEtc;
  Name : array [0..OLEUI_CCHPATHMAX-1] of char;
begin
  InitExecute (Io, sizeof (TOleUIInsertObject));

// Put in main flags
  if FShowHelp then
    Io.dwFlags := Io.dwFlags or IOF_SHOWHELP;
  if FSelectCreateNew then
    Io.dwFlags := Io.dwFlags or IOF_SELECTCREATENEW;
  if FSelectCreateFromFile then
    Io.dwFlags := Io.dwFlags or IOF_SELECTCREATEFROMFILE;
  if FCheckLink then
    Io.dwFlags := Io.dwFlags or IOF_CHECKLINK;
  if FCheckDisplayAsIcon then
    Io.dwFlags := Io.dwFlags or IOF_CHECKDISPLAYASICON;
  if FCreateNewObject then
    Io.dwFlags := Io.dwFlags or IOF_CREATENEWOBJECT;
  if FCreateFileObject then
    Io.dwFlags := Io.dwFlags or IOF_CREATEFILEOBJECT;
  if FCreateLinkObject then
    Io.dwFlags := Io.dwFlags or IOF_CREATELINKOBJECT;
  if FDisableLink then
    Io.dwFlags := Io.dwFlags or IOF_DISABLELINK;
  if FVerifyServersExist then
    Io.dwFlags := Io.dwFlags or IOF_VERIFYSERVERSEXIST;
  if FDisableDisplayAsIcon then
    Io.dwFlags := Io.dwFlags or IOF_DISABLEDISPLAYASICON;
  if FHideChangeIcon then
    Io.dwFlags := Io.dwFlags or IOF_HIDECHANGEICON;
  if FShowInsertControl then
    Io.dwFlags := Io.dwFlags or IOF_SHOWINSERTCONTROL;
  if FSelectCreateControl then
    Io.dwFlags := Io.dwFlags or IOF_SELECTCREATECONTROL;
// Fill CLSID exclusions
  Pca := MakeCLSIDArray (FExclude, PcaSize);
  Io.lpClsidExclude := pointer (Pca);
  Io.cClsidExclude := FExclude.Count;
// Set filename parameters and clear the filename