oledataobject.pas

是一个delphi的流程制作软件

        if Medium = cmMFPict then
          if Picture.Graphic is TMetafile then
            Result := ConvertMetafile (Picture.Metafile)
          else
            Result := MakeMFWrapper (Picture.Graphic);
    else
// Other defined formats require specific tests not allowed by the
// case statment as we're now comparing variables
      if (Format = cfIcon) and (Medium = cmGlobal) then
      begin
        Result := MakeGlobal (Picture.Icon);
        exit
      end;
{$IFDEF GIF}
      if (Format = cfGIF) and (Medium = cmGlobal) then
      begin
        Result := MakeGlobal (Picture.Graphic as TGifImage);
        exit
      end;
{$ENDIF}

      if Format = cfFileContents then
      begin
        Result := MakeGlobal (Picture.Graphic);
        exit
      end;

      if Format = cfFileDescriptor then
      begin
        InitFileDescriptor (T);
        with T do
        begin
          if FScrapFilename = '' then
            S := 'Picture Scrap'
          else
            S := FScrapFilename;
          FileName := S + '.' + GraphicExtension (TGraphicClass(Picture.Graphic.ClassType));
          FileSize := GraphicSize (Picture.Graphic)
        end;
        Result := MakeGlobal ([T]);
        exit
      end;

      Result := inherited ProvideData (Format, Medium, Aspect, AIndex);
      if Result <> 0 then
        exit;

// more predefined formats can go here...

    end
  end
end;

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

//=== Functions that return things from Controls using RTTI ====================

function HasProperty (AControl : TControl; const Prop : ShortString) : boolean;
begin
  Result := Assigned (AControl) and
    Assigned (GetPropInfo (AControl.ClassInfo, Prop))
end;

function StrProperty (AControl : TControl; const Prop : ShortString) : string;
var
  P : PPropInfo;
begin
  Result := '';
  if Assigned (AControl) then
  begin
    P := GetPropInfo (AControl.ClassInfo, Prop);
    if Assigned (P) then
      Result := GetStrProp (AControl, P)
  end
end;

function IntProperty (AControl : TControl; const Prop : ShortString) : integer;
var
  P : PPropInfo;
begin
  Result := -1;
  if Assigned (AControl) then
  begin
    P := GetPropInfo (AControl.ClassInfo, Prop);
    if Assigned (P) then
      Result := GetOrdProp (AControl, P)
  end
end;

// Hardwired TPageControl to get caption of current page, hardwired
// TListView for case when not in multiselect (ie single select) mode, otherwise
// use the Caption property.
function HasCaption (AControl : TControl) : boolean;
begin
  if AControl is TListView then
    Result := not TListView (AControl).MultiSelect
  else
    Result := HasProperty (AControl, 'Caption') or (AControl is TPageControl)
end;

function Caption (AControl : TControl) : string;
begin
  if AControl is TPageControl then
    Result := TPageControl (AControl).ActivePage.Caption
  else
    if AControl is TListView then
      with TListView (AControl) do
        if Assigned (Selected) then
          Result := Selected.Caption
        else
    else
      Result := StrProperty (AControl, 'Caption')
end;

// Need hardwired case for TCustomMemo where Text property is
// not published, TTreeView where we want the Text property of the
// selected node. Otherwise ask for the Text property.
function HasText (AControl : TControl) : boolean;
begin
  Result := (AControl is TCustomMemo) or
            (AControl is TTreeView) or
             HasProperty (AControl, 'SelText') or
             HasProperty (AControl, 'Text')
end;

function Text_ (AControl : TControl) : string;
begin
  if AControl is TTreeView then
    with AControl as TTreeView do
      if Assigned (Selected) then
        Result := Selected.Text
      else
        Result := ''
  else
    if AControl is TCustomEdit then
    begin
      Result := TCustomEdit (AControl).SelText;
      if Result = '' then
        Result := TCustomEdit (AControl).Text
    end else
      Result := StrProperty (AControl, 'Text')
end;

function HasLines (AControl : TControl) : boolean;
begin
  Result := HasProperty (AControl, 'Lines')
end;

function Lines (AControl : TControl) : TStrings;
begin
  Result := pointer (IntProperty (AControl, 'Lines'))
end;

function HasItems (AControl : TControl) : boolean;
begin
  Result := HasProperty (AControl, 'Items')
end;

function Items (AControl : TControl) : TStrings;
begin
  Result := pointer (IntProperty (AControl, 'Items'))
end;

// Hardwire the TCustomListBox as the ItemIndex property is not published
// otherwise use the ItemIndex property
function HasItemIndex (AControl : TControl) : boolean;
begin
  Result := (AControl is TCustomListBox) or
             HasProperty (AControl, 'ItemIndex')
end;

function ItemIndex (AControl : TControl) : integer;
begin
  if AControl is TCustomListBox then
    Result := TCustomListBox (AControl).ItemIndex
  else
    Result := IntProperty (AControl, 'ItemIndex')
end;

function ItemIndexText (AControl : TControl) : string;
var
  I : integer;
begin
  I := ItemIndex (AControl);
  if I < 0 then
    Result := ''
  else
    Result := Items (AControl) [I]
end;

function HasTabs (AControl : TControl) : boolean;
begin
  Result := HasProperty (AControl, 'Tabs')
end;

function Tabs (AControl : TControl) : TStrings;
begin
    Result := pointer (IntProperty (AControl, 'Tabs'))
end;

function HasTabIndex (AControl : TControl) : boolean;
begin
  Result := HasProperty (AControl, 'TabIndex')
end;

function TabIndex (AControl : TControl) : integer;
begin
  Result := IntProperty (AControl, 'TabIndex')
end;

function TabIndexText (AControl : TControl) : string;
var
  I : integer;
begin
  I := TabIndex (AControl);
  if I < 0 then
    Result := ''
  else
    Result := Tabs (AControl) [I]
end;

// Multi selection is possible for a TListBox (if MultiSelect is true),
// a TCheckListBox and a TListView (if MultiSelect is true)
function HasMultiSelect (AControl : TControl) : boolean;
begin
  if AControl is TListBox then
    Result := TListBox (AControl).MultiSelect
  else
    if AControl is TListView then
      Result := TListView (AControl).MultiSelect
    else
      Result := AControl is TCheckListBox
end;

function MultiSelectList (AControl : TControl) : TStringList;
var
  Loop : integer;
begin
  Result := TStringList.Create;

// get selected stuff from TCheckListBox
  if AControl is TCheckListBox then
  begin
    with AControl as TCheckListBox do
      for Loop := 0 to Items.Count - 1 do
         if State [Loop] = cbChecked then
           Result.Add (Items [Loop]);
    exit
  end;

// Get selected stuff from a TListBox
  if AControl is TListBox then
  begin
    with AControl  as TListBox do
      if MultiSelect then
        for Loop := 0 to Items.Count - 1 do
          if Selected [Loop] then
            Result.Add (Items[Loop]);
    exit
  end;

// Get selected stuff from a TListView
  if AControl is TListView then
    with AControl as TListView do
      if MultiSelect then
        for Loop := 0 to Items.Count - 1 do
          if Items[Loop].Selected then
            Result.Add (Items[Loop].Caption)
end;

function MultiSelect (AControl : TControl) : string;
begin
  with MultiSelectList (AControl) do
  try
    Result := CommaText
  finally
    Free
  end
end;

function GetTextAvailable (AControl : TControl) : string;
begin
  if HasItems (AControl) and HasItemIndex (AControl) then
    Result := ItemIndexText (AControl)
  else
    if HasTabs (AControl) and HasTabIndex (AControl) then
      Result := TabIndexText (AControl)
    else
      if HasText (AControl) then
        Result := Text_ (AControl)
      else
        if HasCaption (AControl) then
          Result := Caption (AControl)
       else
         Result := ''
end;

//=== CONTROL SOURCE ===========================================================

function TCustomControlDataSource.IsControl : boolean;
begin
  Result := not Assigned (FControl)
end;

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

//=== STRING SOURCE ============================================================

constructor TCustomStringDataSource.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  FStrings := TStringList.Create;
  FAutoLocale := true;
  FFormats := DefaultFormats
end;

destructor TCustomStringDataSource.Destroy;
begin
  FStrings.Free;
  inherited Destroy
end;

procedure TCustomStringDataSource.SetText (Value : string);
begin
  if (not Assigned (FControl)) and (Value <> FText) then
    FText := Value
end;

function TCustomStringDataSource.GetText : string;
begin
  if Assigned (FControl) then
    Result := GetTextAvailable (FControl)
  else
    Result := FText
end;

procedure TCustomStringDataSource.SetStrings (Value : TStrings);
begin
  if not Assigned (FControl) then
    FStrings.Assign (Value)
end;

function TCustomStringDataSource.GetStrings : TStrings;
var
  S : TStringList;
begin
  if Assigned (FControl) then
  begin
    if HasMultiSelect (FControl) then
    begin
      S := MultiSelectList (FControl);
      try
        FStrings.Assign (S);
      finally
        S.Free
      end
    end else
      if HasLines (FControl) then
        FStrings.Assign (Lines (FControl))
  end;

  Result := FStrings
end;

function TCustomStringDataSource.ProvideFormats : TFormatEtcList;
begin
  Result := inherited ProvideFormats;

  if (Assigned (FControl) and (HasCaption (FControl) or HasText (FControl) or
    HasTabs (FControl) or (HasItemIndex (FControl) and HasItems (FControl)))) or
     (not Assigned (FControl) and (FText <> '')) then
  begin
    if sfText in FFormats then
      Result.Add;
    if sfOemText in FFormats then
      with Result.Add do
        Format := cfOemText;
    if sfFilename in FFormats then
      with Result.Add do
        Format := cfFilename
  end;

  if (Assigned (FControl) and (HasMultiSelect (FControl) or HasLines (FControl))) or
     (not Assigned (FControl) and (FStrings.Count > 0)) then
  begin
    if sfCSV in FFormats then
      with Result.Add do
        Format := cfCSV;
    if sfFilenames in FFormats then
      with Result.Add do
        Format := cfHDrop;
    if sfPrinters in FFormats then
      with Result.Add do
        Format := cfPrinters
  end;

  if FAutoLocale and (Result.Count > 0) then
    with Result.Add do
      Format := cfLocale;

// If create scrap file is enabled then put file descriptor and contents
// formats in
  if FScrapAllow then
  begin
    with Result.Add do