Sample Application: EmbedTest.dpr

Project source
Form source (Pascal)
Form source (DFM)

Design-time form image
Project source: EmbedTest.dpr 

program EmbedTest;

{Sample application for UnitOOPS OLE Drag and Drop Components}
uses
  Forms,
  fmEmbedTest in 'fmEmbedTest.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
Back to top
Form source: fmEmbedTest.pas 

unit fmEmbedTest;
{ UnitOOPS OLE Drag and Drop Components - Example
  for accepting OLE object copy and link drops.
  Also shows how to save the object to disk.

 Last modified:  04/29/99}
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ActiveX, uoole, OleCtnrs, StdCtrls, ExtCtrls, Menus;

type
  TForm1 = class(TForm)
    UOTextTarget1: TUOTextTarget;
    Panel1: TPanel;
    Label1: TLabel;
    Panel2: TPanel;
    RadioGroup1: TRadioGroup;
    Button1: TButton;
    CheckBox1: TCheckBox;
    Panel4: TPanel;
    Panel3: TPanel;
    Panel5: TPanel;
    OleContainer1: TOleContainer;
    SaveDialog1: TSaveDialog;
    Button2: TButton;
    Label2: TLabel;
    procedure UOTextTarget1Drop(Sender: TObject; Acceptor: TWinControl;
      const dropText: String; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure OleContainer1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FVerbsMenu: TPopupMenu;

    procedure BuildVerbsMenu;
    procedure VerbsMenuOnClick(Sender: TObject);
    procedure OleContainer1DblClick(Sender: TObject);
    procedure GetOleClassInfo(const aOleObject: IOleObject;
      var defaultExt, typeName: string);
  public
    { Public declarations }
  end;

  THackOleContainer = class(TOleContainer);

var
  Form1: TForm1;

implementation

uses
  ComObj, Registry, uoUtil;

{$R *.DFM}

procedure TForm1.UOTextTarget1Drop(Sender: TObject; Acceptor: TWinControl;
  const dropText: String; X, Y: Integer);
// OLE object drop handler.  A link source has been dropped on the acceptor
// control.  Build a TCreateInfo, and have the OleContainer create the
// object.
var
  aCI: TCreateInfo;
begin
  FillChar(aCI, sizeOf(TCreateInfo), 0);

  with aCI do
  begin
    // Type of link, based on radio group selection
    if (RadioGroup1.ItemIndex = 1) then
      CreateType := ctFromData
    else
      CreateType := ctLinkFromData;

    // Show as icon, based on checkbox selection
    ShowAsIcon := CheckBox1.Checked;

    // We'll build the object from the TUOTextTarget's IDataObject
    DataObject := UOTextTarget1.DataObject;
  end;    // with

  // Do it.
  OLEContainer1.CreateObjectFromInfo(aCI);

  // Manually build the verbs popup menu, so we can trap errors
  BuildVerbsMenu;

  // Put the title on the caption panel
  Panel3.Caption := OleContainer1.SourceDoc +' ['+OLEContainer1.OleClassName+']';

  // Enable the Save As... button, but only for create (not link)
  Button2.Enabled := (aCI.CreateType = ctFromData);
end;

procedure TForm1.VerbsMenuOnClick(Sender: TObject);
// Handler for all OLE object verbs menu items.
var
  aMenuItem: TMenuItem;
begin
  // Get the sender menu item
  aMenuItem := (Sender as TMenuItem);

  // The verb index is in tag
  // try/except for the case where the application that originated the link
  // has been closed, e.g.
  try
    OleContainer1.DoVerb(aMenuItem.Tag);
  except
    on EOleSysError do
    begin
      MessageBox(Self.Handle,
        PChar(Format('OLE error: %s.  The link source was probably closed',
          [SysErrorMessage(GetLastError)])),
        'UnitOOPS OLE Linking Demo', MB_OK + MB_ICONEXCLAMATION + MB_SETFOREGROUND);
    end;
  end;

end;

procedure TForm1.BuildVerbsMenu;
// Construct the menu for the embedded OLE object.  This could be done
// automatically if OleContainer1.AutoActive is aaDoubleClick, but we want
// to know when the commands are being issued.
var
  j: integer;
  aMenuItem: TMenuItem;
begin
  if assigned(OLEContainer1.OleObjectInterface) then
  begin
    // Free the old popup menu, and make a new one.
    if assigned(FVerbsMenu) then
      FVerbsMenu.Free;
    FVerbsMenu := TPopupMenu.Create(Self);

    // Loop over the object's verbs, building a menu item for each one.
    for j := 1 to OLEContainer1.ObjectVerbs.Count do    // Iterate
    begin
      aMenuItem := TMenuItem.Create(FVerbsMenu);
      with aMenuItem do
      begin
        Caption := OLEContainer1.ObjectVerbs[j-1];
        // Use a single handler for all menu items.
        OnClick := VerbsMenuOnClick;
        // Store the verb's index in the tag property.
        Tag := j-1;
      end;    // with
      FVerbsMenu.Items.Add(aMenuItem);
    end;    // for
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Tell potential drag sources we want objects
  with UOTextTarget1, CustomFormats do
  begin
    OverrideDropEffects[deMove] := deCopy; // No moves allowed!
    Add('Link Source');
    Add('Link Source Descriptor');
  end;    // with

  // Use a dirty hack to expose the OnDblClick event.
  THackOleContainer(OleContainer1).OnDblClick := OleContainer1DblClick;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Stop editing in place, and disable the Save As... button
  OleContainer1.Close;
  Button2.Enabled := false;
end;

procedure TForm1.OleContainer1DblClick(Sender: TObject);
// Sleazy hacked double-click handler, since OleContiner doesn't
// surface OnDblClick
begin
  if assigned(OleContainer1.OleObjectInterface) then
  begin
    try
      OleContainer1.DoVerb(ovPrimary);
    except
      on EOleSysError do
      begin
        MessageBox(Self.Handle,
          PChar(Format('OLE error: %s.  The link source was probably closed',
            [SysErrorMessage(GetLastError)])),
          'UnitOOPS OLE Linking Demo', MB_OK + MB_ICONEXCLAMATION + MB_SETFOREGROUND);
      end;
    end;

  end;
end;

procedure TForm1.OleContainer1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
// On right button click, popup the verbs menu.
var
  aPt: TPoint;
begin
  if assigned(OleContainer1.OleObjectInterface) then
  begin

    if (Button = mbRight) then
    begin
      aPt.X := X;  aPt.Y := Y;
      aPt := OleContainer1.ClientToScreen(aPt);
      FVerbsMenu.Popup(aPt.X, aPt.Y);
    end;
  end;

end;

procedure TForm1.GetOleClassInfo(const aOleObject: IOleObject;
  var defaultExt, typeName: string);
// Given the IOleObject interface to an object, return the default
// extension (including the ., e.g., .doc) and the friendly name for
// the type (e.g., Microsoft Word Document).
var
  reg: TRegistry;
  S: string;
begin
  defaultExt := '';
  typeName := '';

  reg:= TRegistry.Create;
  Try
    reg.Rootkey := HKEY_CLASSES_ROOT;

    // OleClassname is e.g. Word.Document.8
    if reg.OpenKey(OleContainer1.OleClassName, false) then
    begin
      // Default value is type name
      typeName := reg.ReadString('');
      reg.CloseKey;

      // Now, get the CLSID}
      if reg.OpenKey(Format('%s\CLSID', [OleContainer1.OleClassName]), false) then
      begin
        s := reg.ReadString('');
        reg.CloseKey;

        // Use the CLSID to fine the default extension
        if reg.OpenKey(Format('CLSID\%s\DefaultExtension', [s]), false) then
        begin
          s := reg.ReadString('');
          defaultExt := Copy(s, 1, 4);
          reg.CloseKey;
        end;
      end;
    end;

  Finally
    // Clean up
    reg.free;
  End;

end;

procedure TForm1.Button2Click(Sender: TObject);
// We're going to save.  Make sure we put up the object type and the
// correct extension
var
  typeName, defaultExtension: string;
begin
  // Get the information from the registry
  GetOleClassInfo(OleContainer1.OleObjectInterface, defaultExtension, typeName);
  with SaveDialog1 do
  begin
    // Set up the TSaveDialog
    DefaultExt := Copy(defaultExtension, 2, 3);
    FileName := '*.'+DefaultExt;
    Filter  := typeName+'|'+FileName;

    // Run the dialog
    if Execute then
    begin
      // If the user pressed OK, save the document
      OleContainer1.SaveAsDocument(FileName);
      // Alternative method:
      // uoSaveIStorageToFile(OleContainer1.StorageInterface, FileName);
    end;
  end;    // with

end;

end.
Back to top
Form source: fmEmbedTest.dfm 

object Form1: TForm1
  Left = 297
  Top = 189
  Width = 551
  Height = 340
  Caption = 'Test of OLE linking and embedding by drag-and-drop'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 543
    Height = 49
    Align = alTop
    BevelOuter = bvNone
    BorderWidth = 3
    Locked = True
    TabOrder = 0
    object Label1: TLabel
      Left = 3
      Top = 3
      Width = 537
      Height = 43
      Align = alClient
      Caption = 
        'Drop content from e.g., Word or Excel onto the TOLEContainer bel' +
        'ow.  Use the radio buttons to choose between linking or copying ' +
        'the object.  To finish editing a copied object, use the "Close O' +
        'LE container" button.  Right-click for editing options.'
      WordWrap = True
    end
  end
  object Panel2: TPanel
    Left = 358
    Top = 49
    Width = 185
    Height = 264
    Align = alRight
    BevelOuter = bvNone
    Locked = True
    TabOrder = 1
    object RadioGroup1: TRadioGroup
      Left = 6
      Top = 0
      Width = 177
      Height = 72
      Caption = 'Type of object drop'
      ItemIndex = 1
      Items.Strings = (
        'Link to original object'
        'Create new object')
      TabOrder = 0
    end
    object Button1: TButton
      Left = 8
      Top = 106
      Width = 121
      Height = 24
      Caption = 'Close OLE container'
      TabOrder = 1
      OnClick = Button1Click
    end
    object CheckBox1: TCheckBox
      Left = 8
      Top = 80
      Width = 169
      Height = 17
      Caption = 'Show object as icon'
      TabOrder = 2
    end
    object Button2: TButton
      Left = 8
      Top = 136
      Width = 121
      Height = 25
      Caption = 'Save As...'
      Enabled = False
      TabOrder = 3
      OnClick = Button2Click
    end
  end
  object Panel4: TPanel
    Left = 0
    Top = 49
    Width = 358
    Height = 264
    Align = alClient
    BevelOuter = bvNone
    Caption = 'Panel4'
    TabOrder = 2
    object Panel3: TPanel
      Left = 0
      Top = 0
      Width = 358
      Height = 22
      Align = alTop
      BevelOuter = bvNone
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = [fsBold]
      ParentFont = False
      TabOrder = 0
      object Label2: TLabel
        Left = 4
        Top = 4
        Width = 5
        Height = 13
      end
    end
    object Panel5: TPanel
      Left = 0
      Top = 22
      Width = 358
      Height = 242
      Align = alClient
      BevelOuter = bvLowered
      Caption = 'Panel5'
      TabOrder = 1
      object OleContainer1: TOleContainer
        Left = 1
        Top = 1
        Width = 356
        Height = 240
        AutoActivate = aaManual
        Align = alClient
        BorderStyle = bsNone
        Caption = 'OleContainer1'
        Color = clWhite
        TabOrder = 0
        OnMouseDown = OleContainer1MouseDown
      end
    end
  end
  object UOTextTarget1: TUOTextTarget
    AcceptorControl = OleContainer1
    AcceptTextFormats = [dtfCustom]
    OnDrop = UOTextTarget1Drop
    Left = 160
    Top = 160
  end
  object SaveDialog1: TSaveDialog
    Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing]
    Left = 454
    Top = 241
  end
end
Back to top

Back to the examples page