oledlgs.pas

是一个delphi的流程制作软件

  end;

  TConvertFormat = class (TCustomFormat)
  private
    procedure SetAspect (const Value : TClipAspect); override;
  protected
  public
  published
    property Aspect;
    property Format;
    property Name;
  end;

  TConvertSelect = (csConvertTo, csActivateAs);
  TOleConvertDialog = class (TOleBaseDialog)
  private
    FFormat : TConvertFormat;
    FSelect : TConvertSelect;
    FActivateDefault,
    FConvertDefault : TDefaultCLSID;
    FIconChanged,
    FIsLinked,
    FDisableDisplayAsIcon,
    FDisableActivateAs,
    FHideChangeIcon,
    FConvertOnly,
    FShowHelp :  boolean;
    FNewCLSID : TCLSID;
    FUserType,
    FIconLabel : string;
    FCLSID : TCLSIDStr;
    FMetafile : TUIMetafile;
    FExclude : TStrings;
    procedure SetMetafile (Value : TUIMetafile);
    function StoreMetafile : boolean;
    function GetAsCLSID : TCLSID;
    procedure SetAsCLSID (Value : TCLSID);
    procedure SetExclude (Value : TStrings);
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
    function Execute : boolean; override;
// out
    property NewCLSID : TCLSID read FNewCLSID;
    property AsCLSID : TCLSID read GetAsCLSID write SetAsCLSID;
    property IconChanged : boolean read FIconChanged;
  published
// in only
    property Format : TConvertFormat read FFormat write FFormat;
    property DisableDisplayAsIcon : boolean read FDisableDisplayAsIcon write FDisableDisplayAsIcon default false;
    property DisableActivateAs : boolean read FDisableActivateAs write FDisableActivateAs default false;
    property HideChangeIcon : boolean read FHideChangeIcon write FHideChangeIcon default false;
    property ConvertOnly : boolean read FConvertOnly write FConvertOnly default false;
    property ShowHelp : boolean read FShowHelp write FShowHelp default false;
    property ConvertDefault : TDefaultCLSID read FConvertDefault write FConvertDefault;
    property ActivateDefault : TDefaultCLSID read FActivateDefault write FActivateDefault;
    property CLSID : TCLSIDStr read FCLSID write FCLSID;
    property IsLinked : boolean read FIsLinked write FIsLinked default false;
    property Exclude : TStrings read FExclude write SetExclude;
// in / out
    property Metafile : TUIMetafile read FMetafile write SetMetafile stored StoreMetafile;
    property Select : TConvertSelect read FSelect write FSelect default csConvertTo;
    property UserType : string read FUserType write FUserType;
    property IconLabel : string read FIconLabel write FIconLabel;
  end;

//=== Ole UI Change Source =====================================================
// This one's not in OleDlg.pas ...

type
  TOleUIChangeSource = record
    cbStruct: Longint;              // Structure Size
    dwFlags: Longint;               // IN-OUT: Flags
    hWndOwner: HWnd;                // Owning window
    lpszCaption: PChar;             // Dialog caption bar contents
    lpfnHook: TFNOleUIHook;         // Hook callback
    lCustData: Longint;             // Custom data to pass to hook
    hInstance: THandle;             // Instance for customized template name
    lpszTemplate: PChar;            // Customized template name
    hResource: HRsrc;               // Customized template handle
// INTERNAL ONLY: do not modify these members
    lpOFN : POpenFilename;          // pointer OPENFILENAME struct
    dwReserved1 : array [1..4] of longint;
// Specifics for OLEUICHANGESOURCE.
    lpOleUILinkContainer : IOleUILinkContainer;   // IN: used to validate link sources
    dwLink : DWORD;                 // IN: magic# for lpOleUILinkContainer
    lpszDisplayName : PChar;        // IN-OUT: complete source display name
    nFileLength : ULONG;            // IN-OUT: file moniker part of lpszDisplayName
    lpszFrom : PChar;               // OUT: prefix of source changed from
    lpszTo : PChar;                 // OUT: prefix of source changed to
  end;

function OleUIChangeSource (var Cs : TOleUIChangeSource) : HRESULT; stdcall;

// Change Source Dialog flags
const
  CSF_SHOWHELP       = $00000001; // IN: enable/show help button
  CSF_VALIDSOURCE    = $00000002; // OUT: link was validated
  CSF_ONLYGETSOURCE  = $00000004; // IN: disables validation of source
  CSF_EXPLORER       = $00000008; // IN: use new OFN_EXPLORER custom template behavior

// Error constants are in OleErrors.pas
//                        -------------

// Dialog Component -
type
  TOleChangeSourceDialog = class (TOleBaseDialog)
  private
    FValidSource,
    FOnlyGetSource,
    FExplorer,
    FShowHelp :  boolean;
    FDisplayName,
    FFromName,
    FToName : string;
    FLink,
    FFileLength : integer;
    FLinkContainer : IOleUILinkContainer;
  public
    constructor Create (AOwner : TComponent); override;
    function Execute : boolean; override;
// in but not published
    property LinkContainer : IOleUILinkContainer read FLinkContainer write FLinkContainer;
// out
    property ValidSource : boolean read FValidSource;
    property ToName : string read FToName;
    property FromName : string read FFromName;
  published
// in only
    property Explorer : boolean read FExplorer write FExplorer default true;
    property ShowHelp : boolean read FShowHelp write FShowHelp default false;
    property OnlyGetSource : boolean read FOnlyGetSource write FOnlyGetSource default false;
// in / out
    property Link : integer read FLink write FLink default 0;
    property DisplayName : string read FDisplayName write FDisplayName;
    property FileLength : integer read FFileLength write FFileLength default 0;
  end;

//=== Ole UI Prompt User Dialog ================================================
// This does not use the standard Ole UI Dialog structure
// A simple API call with 3 or 4 parameters only is used, no
// hook no easy customisation.

type
  TOleUserReturn = (urFalse, urCancel, urOk, urLinks, urHelp, urConvert);
  TOlePromptUserStyle = (usLinkSourceUnavailable, usCannotUpdateLink, usServerNotReg,
    usServerNotFound, usOutOfMemory, usLinkTypeChanged);
  TOlePromptUserDialog = class (TComponent)
  private
    FParam,
    FCaption : string;
    FStyle : TOlePromptUserStyle;
  public
    function Execute : TOleUserReturn;
  published
    property Caption : string read FCaption write FCaption;
    property Param : string read FParam write FParam;
    property UserStyle : TOlePromptUserStyle read FStyle write FStyle;
  end;

//=== OleUIUpdateLinks==========================================================
// The dialog is not based on the base structure above. Its very much simpler.
// You call it to update the links in a document.  It calls the linked objects
// that have the automatic update flag set.  It displays a simple dialog with a
// progress bar and a stop button.  Execute returns false if any of the updates
// fail.  Leave the Caption property empty for a default title.

  TOleUpdateLinksDialog = class (TComponent)
  private
    FCaption : string;
    FCount : integer;
    FLinks : IOleUILinkContainer;
  public
    function Execute : boolean;
    property Links : IOleUILinkContainer read FLinks write FLinks;
    property Count : integer read FCount write FCount;
  published
    property Caption : string read FCaption write FCaption;
  end;

//=== Utilities ================================================================

// Alternative function to using the VCL style dialog component
function OleStdPromptUser (Style : TOlePromptUserStyle; Caption : string; Param : string = '') : TOleUserReturn;

// Utility routines of use outside this unit
function XlatOleUIPasteFormat (Value : TOlePasteFormatOptions) : integer;
procedure CentreWindow (Wnd: HWnd);

// Dialog hooks to chain to if overriding
function OleDialogHook (Wnd : HWnd; Msg, WParam, LParam : Longint): Longint stdcall;
function OleDialogHookBusyEx (Wnd : HWnd; Msg, WParam, LParam : Longint): Longint stdcall;
function OleDialogHookPasteSpecialEx (Wnd : HWnd; Msg, WParam, LParam : Longint): Longint stdcall;

// API Calls not in OleDlg unit
function OleUIPromptUser (Template : integer; Parent : hWnd; Caption : PChar; Param : POleStr = nil) : integer; stdcall;
function OleUIUpdateLinks (OleUILinkCntr : IOleUILinkContainer; Parent : hWnd; Caption : PChar; Links : integer) : BOOL; stdcall;

const
  OLEUI_CCHPATHMAX = 256;

//------------------------------------------------------------------------------

implementation

{$R OleUIPrompt.RES}

// Converts a TOlePasteFormatOptions type into an integer value
function XlatOleUIPasteFormat (Value : TOlePasteFormatOptions) : integer;
const
  Xlat : array [TOlePasteFormatOption] of integer =
  (OLEUIPASTE_LINKTYPE1, OLEUIPASTE_LINKTYPE2, OLEUIPASTE_LINKTYPE3, OLEUIPASTE_LINKTYPE4,
   OLEUIPASTE_LINKTYPE5, OLEUIPASTE_LINKTYPE6, OLEUIPASTE_LINKTYPE7, OLEUIPASTE_LINKTYPE8,
   OLEUIPASTE_PASTE, OLEUIPASTE_LINKANYTYPE, OLEUIPASTE_ENABLEICON);
var
  Loop : TOlePasteFormatOption;
begin
  Result := 0;
  for Loop := low (TOlePasteFormatOption) to high (TOlePasteFormatOption) do
    if Loop in Value then
      Result := Result or Xlat[Loop]
end;

// Fill out a TFormatEtc record, using common defaults
function SetFormatEtc (Cf : TClipFormat; med: Longint; td: PDVTargetDevice = nil;
  Asp: Longint = DVASPECT_CONTENT; li: Longint = -1) : TFormatEtc;
begin
  with Result do
  begin
    cfFormat := cf;
    dwAspect := asp;
    ptd := td;
    tymed := med;
    lindex := li
  end
end;

//--- used to pass an array of CLSIDs
// Some ole ui dialogs allow an array of class ids to be passed which
// are excluded from use by the dialog.  The dialog wrappers hold the
// list as a TStringList for easy editing, this utility function converts
// the string list into an array of class ids.  Also returned is the memory
// allocated which must be freed by the user.

type
  PCLSIDArray = ^TCLSIDArray;
  TCLSIDArray = array [0..0] of TCLSID;

(*
function StringToCLSID (const S: string): TCLSID;
begin
  if CLSIDFromProgID (PWideChar(WideString(S)), Result) <> S_OK then
    OleCheck (CLSIDFromString (PWideChar(WideString(S)), Result))
end; *)

function MakeCLSIDArray (InCLSID : TStrings; var Size : integer) : PCLSIDArray;
var
  Loop : integer;
begin
  Result := nil;
  Size := InCLSID.Count * sizeof (TCLSID);
  if Size > 0 then
  begin
    GetMem (Result, Size);
    if not Assigned (Result) then
      OutOfMemoryError;
{$R-}
    for Loop := 0 to InCLSID.Count - 1 do
      Result^[Loop] := OleStdStringToCLSID (InCLSID [Loop])
{$R+}
  end;
end;

type
  PPasteEntryArray = ^TPasteEntryArray;
  TPasteEntryArray = array [0..0] of TOleUIPasteEntry;

function MakePasteEntriesArray (Entries : TPasteEntryList; var Size : integer) : PPasteEntryArray;
var
  Loop : integer;
  Item : TPasteEntryItem;
begin
  Result := nil;
  Size := Entries.Count * sizeof (TOleUIPasteEntry);
  if Size > 0 then
  begin
    GetMem (Result, Size);
    if not Assigned (Result) then
      OutOfMemoryError;
    for Loop := 0 to Entries.Count - 1 do
{$R-}
      with Result^[Loop] do
      begin
        Item := Entries.Items [Loop];
        fmtetc := SetFormatEtc (Item.Format, XlatMediums (Item.Medium), nil, XlatAspect (Item.Aspect));
        lpstrFormatName := PChar (Item.Text);
        lpstrResultText := PChar (Item.Result);
        dwFlags := XlatOleUIPasteFormat (Item.FOptions)
      end
{$R+}
  end
end;

//=== BASE DIALOG ==============================================================

procedure CentreWindow (Wnd: HWnd);
var
  Rect: TRect;
  Monitor: TMonitor;
begin
  if GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD <> 0 then
    Wnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
  GetWindowRect (Wnd, Rect);
  if Assigned (Application.MainForm) then
    Monitor := Application.MainForm.Monitor
  else
    Monitor := Screen.Monitors [0];
  SetWindowPos(Wnd, 0,
    Monitor.Left + ((Monitor.Width - Rect.Right + Rect.Left) div 2),
    Monitor.Top + ((Monitor.Height - Rect.Bottom + Rect.Top) div 3),
    0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER)
end;

var
  CentreDlg : boolean;

function OleDialogHook (Wnd : HWnd; Msg, WParam, LParam : longint): longint stdcall;
begin

  Result := 0;
  if Msg = WM_INITDIALOG then
    with TOleBaseDialog (LParam) do
    begin
      if Assigned (FOnCreate) then
        FOnCreate (pointer (LParam), Wnd);
      if FExplorerDlg then
        CentreDlg := FAutoCentre
      else
        if FAutoCentre then
          CentreWindow (Wnd)
    end
  else
    if (Msg = WM_NOTIFY) and (POFNotify(LParam)^.hdr.code = CDN_INITDONE) and CentreDlg then
      CentreWindow (Wnd)
end;

constructor TOleBaseDialog.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FAutoCentre := true;
  FHook := OleDialogHook;
  FData := integer (Self)
end;

// This is called by all of the dialogs that are derived from TOleBaseDialog
// at the beginning of the execute function.
procedure TOleBaseDialog.InitExecute (var Dialog; Size : integer);
// All OleDialogs that derive from TOleBaseDialog must use this structure
type
  TBaseDialog = record
    cbStruct: Longint;
    dwFlags: Longint;
    hWndOwner: HWnd;
    lpszCaption: PChar;
    lpfnHook: TFNOleUIHook;
    lCustData: Longint;
    hInstance: THandle;
    lpszTemplate: PChar;
    hResource: HRsrc
  end;
var
  Bd : TBaseDialog absolute Dialog;
begin
// Zero memory and put size param in
  ZeroMemory (@Dialog, Size);
  Bd.cbStruct := Size;
// Message hook - used to centre dialog
  Bd.lpfnHook := FHook;
  Bd.lCustData := FData;
// Out App
  Bd.hWndOwner := Application.Handle;
// Use different resource dialog template
  if FResource <> '' then
  begin
    Bd.hInstance := hInstance;
    Bd.hResource := FindResource (hInstance, PChar (FResource), RT_DIALOG);
    Bd.lpszTemplate := PChar (FResource)
  end;
  if FCaption <> '' then
    Bd.lpszCaption := PChar (FCaption)
end;

//=== BASE FORMATETC ===========================================================

procedure TCustomFormat.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 TCustomFormat.SetFormat (const Value : TClipFormat);
begin
  if FFormat <> Value then
  begin
    FFormat := Value;
    FName := GetClipboardFormatName (Value)
  end
end;

procedure TCustomFormat.SetMedium (const Value : TClipMediums);
begin
  FMedium := Value
end;

procedure TCustomFormat.SetAspect (const Value : TClipAspect);
begin
  FAspect := Value
end;

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

//=== BUSY DIALOG ==============================================================

constructor TOleBusyDialog.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FInitial := 5000;
  FRetry := 250;
  FRepeat := 1000
end;

// Default (simple) processing of the retry/rejected dialog