Why Gemfury? Push, build, and install  RubyGems npm packages Python packages Maven artifacts PHP packages Go Modules Debian packages RPM packages NuGet packages

Repository URL to install this package:

Details    
fpc-src / usr / share / fpcsrc / 3.2.0 / tests / test / packages / win-base / tdispvar1.pp
Size: Mime:
{ %TARGET=win32,win64 }
{ %NOTE=This test requires an installed OpenOffice }
{ %INTERACTIVE }
{ This test does create Open Office crashes.
  So we restrict it to interactive mode }
program ttt;

{$ifdef fpc}
{$mode delphi}
{$endif fpc}

uses
  Windows, SysUtils, Classes, ComObj, ActiveX, Variants;

var StarOffice : Variant;
	Document : Variant;

function TSampleCode_Connect(OleName : string) : boolean;
begin
    if  VarIsEmpty(StarOffice) then
      begin
        try
          Writeln('Trying to connect to ',OleName);
          StarOffice := CreateOleObject(OleName);
        except
          on e : exception do
            begin
              StarOffice:=Unassigned;
              Writeln('Connection to ',OleName,' failed: ',e.message);
            end;
          end;
      end;

    Result := not (VarIsEmpty(StarOffice) or VarIsNull(StarOffice));
end;

function TSampleCode_CreateDocument(bReadOnly : boolean) : boolean;
var
    StarDesktop : Variant;
    LoadParams : Variant;
    CoreReflection : Variant;
    PropertyValue : Variant;
    AutoObject : Variant;
    TextObject : Variant;
    Cursor : Variant;
begin
   StarDesktop := StarOffice.createInstance('com.sun.star.frame.Desktop');

   if (bReadOnly) then begin
        LoadParams := VarArrayCreate([0, 0], varVariant);
        CoreReflection := StarOffice.createInstance('com.sun.star.reflection.CoreReflection');

        CoreReflection.forName('com.sun.star.beans.PropertyValue').
			createObject(PropertyValue); // CoreReflection().forName().createObject() bring to "Illegal qualifier"
        AutoObject := CoreReflection.forName('com.sun.star.beans.PropertyValue');
	AutoObject.createObject(PropertyValue);

	PropertyValue.Name := 'ReadOnly'; 	// "Arg cant be assigned" and
        PropertyValue.Value := true;		//	"Incompatimle types: const string, untyped expected"

        LoadParams[0] := PropertyValue;
   end
   else
        LoadParams := VarArrayCreate([0, -1], varVariant);

   Document := StarDesktop.LoadComponentFromURL( 'private:factory/swriter', '_blank', 0,  LoadParams);
   if not bReadOnly then begin
       TextObject := Document.Text;
       Cursor := TextObject.createTextCursor;
       TextObject.insertString(Cursor,'Output of FPC Test tdispvar1.pp',False);
	  // works with D7, but not FPC
   end;

   Result := not (VarIsEmpty(Document) or VarIsNull(Document));
end;

begin
  CoInitialize(nil);
  if TSampleCode_Connect('com.sun.star.ServiceManager') then
    begin
      if TSampleCode_CreateDocument(false) then
        Document.Close(false);

    end;
  StarOffice:=Unassigned;
  if TSampleCode_Connect('com.sun.star.ServiceManager.NonExisting.Variant.Just.To.Test') then
    begin
      if TSampleCode_CreateDocument(false) then
        Document.Close(false);
    end;
  CoUnInitialize;
end.