fpspreadsheet: Add demo hyperlinkdemo which collects the sheets of linked workbooks to a new workbook

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4035 8e941d3f-bd1b-0410-a28a-d453659cc2b4

components/fpspreadsheet/examples/read_write/hyperlinkdemo/collectlinks.lpi

@@ -0,0 +1,70 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="collectlinks"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="laz_fpspreadsheet"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="collectlinks.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="collectlinks"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

components/fpspreadsheet/examples/read_write/hyperlinkdemo/collectlinks.lpr

@@ -0,0 +1,165 @@
+{ This program seeks all spreadsheet hyperlinks in the file "source.xls" and
+  adds the linked worksheet to a new workbook. }
+
+program collectlinks;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Classes, SysUtils, uriParser,
+  fpstypes, fpspreadsheet, fpsUtils, fpsAllFormats
+  { you can add units after this };
+
+const
+  srcFile = 'source.ods';
+  destFile = 'result';
+
+var
+  srcWorkbook, destWorkbook, linkedWorkbook: TsWorkbook;
+  sheet, linkedSheet, destSheet: TsWorksheet;
+  cell: PCell;
+  hyperlink: PsHyperlink;
+  u: TURI;
+  fn: String;  // Name of linked file
+  bookmark: String;  // Bookmark of hyperlink
+  sheetFormat: TsSpreadsheetFormat;
+  sheetName: String;
+  r, c: Cardinal;
+
+begin
+  // Just for the demo: create the file "source.xls". It contains hyperlinks to
+  // some the "test" files created in the XXXXdemo projects
+  Write('Creating source workbook...');
+  srcWorkbook := TsWorkbook.Create;
+  try
+    sheet := srcWorkbook.AddWorksheet('Sheet');
+
+    sheet.WriteUTF8Text(0, 0, 'Link to biff8 test file');
+    sheet.WriteHyperlink(0, 0, '../excel8demo/test.xls#''My Worksheet 2''!A1');
+    //sheet.WriteHyperlink(0, 0, '../excel8demo/test.xls#''Meu Relatório''!A1');
+
+    sheet.WriteUTF8Text(1, 0, 'Link to ods test file');
+    sheet.WriteHyperlink(1, 0, '..\opendocdemo\test.ods');
+
+    sheet.WriteUTF8Text(2, 0, 'E-Mail Link');
+    sheet.WriteHyperlink(2, 0, 'mailto:someone@mail.com;someoneelse@mail.com?Subject=This is a test');
+
+    sheet.WriteUTF8Text(3, 0, 'Web-Hyperlink');
+    sheet.WriteHyperlink(3, 0, 'http://www.lazarus-ide.org/');
+
+    sheet.WriteUTF8Text(4, 0, 'File-Link (absolute path)');
+    sheet.WriteHyperlink(4, 0, 'file:///'+ExpandFilename('..\..\..\tests\testooxml_1899.xlsx'));
+    // This creates the URI such as "file:///D:\Prog_Lazarus\svn\lazarus-ccr\components\fpspreadsheet\tests\testooxml_1899.xlsx"
+    // but makes sure that the file exists on your system.
+
+    sheet.WriteUTF8Text(5, 0, 'Jump to A10');
+    sheet.WriteHyperlink(5, 0, '#A10');
+
+    sheet.WriteColWidth(0, 40);
+
+    srcWorkbook.WriteToFile(srcFile, true);
+  finally
+    srcWorkbook.Free;
+  end;
+  WriteLn('Done.');
+
+  // Prepare destination workbook
+  destWorkbook := nil;
+
+  // Now open the source file and seek hyperlinks
+  Write('Reading source workbook, sheet ');
+  srcWorkbook := TsWorkbook.Create;
+  try
+    srcWorkbook.ReadFromFile(srcFile);
+    sheet := srcWorkbook.GetWorksheetByIndex(0);
+    WriteLn(sheet.Name, '...');
+
+    for cell in sheet.Cells do
+    begin
+      hyperlink := sheet.FindHyperlink(cell);
+      if (hyperlink <> nil) then    // Ignore cells without hyperlink
+      begin
+        WriteLn;
+        WriteLn('Cell ', GetCellString(cell^.Row, cell^.Col), ':');
+        WriteLn('  Hyperlink "', hyperlink^.Target, '"');
+        if (hyperlink^.Target[1] = '#') then
+          WriteLn('  Ignoring internal hyperlink')
+        else
+        begin
+          u := ParseURI(hyperlink^.Target);
+          if u.Protocol = '' then begin
+            Write('  Local file (relative path)');
+            SplitHyperlink(hyperlink^.Target, fn, bookmark)
+          end else
+          if URIToFileName(hyperlink^.Target, fn) then
+            Write('  File (absolute path)')
+          else
+          begin
+            WriteLn('  Ignoring protocol "', u.Protocol, '"');
+            continue;  // Ignore http, mailto etc.
+          end;
+
+          if not FileExists(fn) then
+            WriteLn(' does not exist.')
+          else
+          if GetFormatFromFileName(fn, sheetFormat) then
+          begin
+            Write(' supported. ');
+            // Create destination workbook if not yet done so far...
+            if destWorkbook = nil then
+              destWorkbook := TsWorkbook.Create;
+            // Open linked workbook
+            linkedworkbook := TsWorkbook.Create;
+            try
+              linkedworkbook.ReadFromFile(fn, sheetFormat);
+              // Get linked worksheet
+              if bookmark = '' then
+                linkedSheet := linkedWorkbook.GetWorksheetByIndex(0)
+              else
+                if not linkedWorkbook.TryStrToCell(bookmark, linkedsheet, r, c)
+                then begin
+                  WriteLn('Failure finding linked worksheet.');
+                  continue;
+                end;
+//                linkedSheet := linkedWorkbook.GetWorksheetByName(bookmark);
+              // Copy linked worksheet to new sheet in destination workbook
+              destSheet := destWorkbook.CopyWorksheetFrom(linkedSheet);
+              // Create sheet name
+              sheetName := ExtractFileName(fn) + '#' +linkedSheet.Name;
+              destWorkbook.ValidWorksheetName(sheetName, true);
+              destSheet.Name := sheetName;
+              // Done
+              WriteLn(' Copied.');
+            finally
+              linkedworkbook.Free;
+            end;
+          end;
+        end;
+      end;
+    end;
+
+    // Save destination workbook
+    WriteLn;
+    if destWorkbook <> nil then
+    begin
+      destworkbook.WriteToFile(destFile+'.xls', true);
+      destworkbook.WriteToFile(destFile+'.xlsx', true);
+      destworkbook.WriteToFile(destFile+'.ods', true);
+      WriteLn('All hyperlinks to spreadsheets are collected in files ' + destFile + '.*');
+    end else
+      WriteLn('No hyperlinks found.');
+
+    WriteLn('Press ENTER to close...');
+    ReadLn;
+
+  finally
+    // Clean up
+    srcWorkbook.Free;
+    if destWorkbook <> nil then destWorkbook.Free;
+  end;
+
+end.
+

components/fpspreadsheet/examples/read_write/hyperlinkdemo/readme.txt

@@ -0,0 +1,5 @@
+This sample project demonstrates how to use fpspreadsheet can follow the hyperlinks 
+to other spreadsheet files and copy the linked sheets to a new document.
+
+Please run the write demos ooxmldemo/ooxmlwrite and excel8demp/excel8write before 
+running this project in order to generate required spreadsheet files.

components/fpspreadsheet/examples/visual/fpsctrls/demo_ctrls.lpi

@@ -118,13 +118,6 @@
     <CodeGeneration>
       <SmartLinkUnit Value="True"/>
     </CodeGeneration>
-    <Linking>
-      <Options>
-        <Win32>
-          <GraphicApplication Value="True"/>
-        </Win32>
-      </Options>
-    </Linking>
   </CompilerOptions>
   <Debugging>
     <Exceptions Count="3">

components/fpspreadsheet/fpsopendocument.pas

@@ -3751,6 +3751,8 @@ begin
 
   fnt := Workbook.GetFont(AFormat.FontIndex);
   defFnt := Workbook.GetDefaultfont;
+  if fnt = nil then
+    fnt := defFnt;
 
   if fnt.FontName <> defFnt.FontName then
     Result := Result + Format('style:font-name="%s" ', [fnt.FontName]);

components/fpspreadsheet/fpspreadsheet.pas

@@ -911,6 +911,8 @@ var
   sourceSheet, destSheet: TsWorksheet;
   fmt: TsCellFormat;
   font: TsFont;
+  clr: TsColorvalue;
+  cb: TsCellBorder;
 begin
   Assert(AFromCell <> nil);
   Assert(AToCell <> nil);
@@ -921,8 +923,27 @@ begin
   else
   begin
     fmt := sourceSheet.ReadCellFormat(AFromCell);
-    font := sourceSheet.ReadCellFont(AFromCell);
+    destSheet.WriteCellFormat(AToCell, fmt);
-    fmt.FontIndex := destSheet.WriteFont(AToCell, font.FontName, font.Size, font.Style, font.Color);
+    if (uffBackground in fmt.UsedFormattingFields) then
+    begin
+      clr := sourceSheet.Workbook.GetPaletteColor(fmt.Background.BgColor);
+      fmt.Background.BgColor := destSheet.Workbook.AddColorToPalette(clr);
+      clr := sourceSheet.Workbook.GetPaletteColor(fmt.Background.FgColor);
+      fmt.Background.FgColor := destSheet.Workbook.AddColorToPalette(clr);
+    end;
+    if (uffFont in fmt.UsedFormattingFields) then
+    begin
+      font := sourceSheet.ReadCellFont(AFromCell);
+      clr := sourceSheet.Workbook.GetPaletteColor(font.Color);
+      font.Color := destSheet.Workbook.AddColorToPalette(clr);
+      fmt.FontIndex := destSheet.WriteFont(AToCell, font.FontName, font.Size, font.Style, font.Color);
+    end;
+    if (uffBorder in fmt.UsedFormattingFields) then
+      for cb in fmt.Border do
+      begin
+        clr := sourceSheet.Workbook.GetPaletteColor(fmt.BorderStyles[cb].Color);
+        fmt.BorderStyles[cb].Color := destSheet.Workbook.AddColorToPalette(clr);
+      end;
     destSheet.WriteCellFormat(AToCell, fmt);
   end;
 end;
@@ -7016,6 +7037,7 @@ function TsWorkbook.TryStrToCellRanges(AText: String; out AWorksheet: TsWorkshee
 var
   i: Integer;
   L: TStrings;
+  sheetname: String;
 begin
   Result := false;
   AWorksheet := nil;
@@ -7028,7 +7050,12 @@ begin
   if i = 0 then
     AWorksheet := FActiveWorksheet
   else begin
-    AWorksheet := GetWorksheetByName(Copy(AText, 1, i-1));
+    sheetname := Copy(AText, 1, i-1);
+    if (sheetname <> '') and (sheetname[1] = '''') then
+      Delete(sheetname, 1, 1);
+    if (sheetname <> '') and (sheetname[Length(sheetname)] = '''') then
+      Delete(sheetname, Length(sheetname), 1);
+    AWorksheet := GetWorksheetByName(sheetname);
     if AWorksheet = nil then
       exit;
     AText := Copy(AText, i+1, Length(AText));

components/fpspreadsheet/fpsutils.pas

@@ -2112,9 +2112,8 @@ procedure FixHyperlinkPathDelims(var ATarget: String);
 var
   i: Integer;
 begin
-  if pos('file:', ATarget) = 1 then
+  for i:=1 to Length(ATarget) do
-    for i:=1 to Length(ATarget) do
+    if ATarget[i] = '\' then ATarget[i] := '/';
-      if ATarget[i] = '\' then ATarget[i] := '/';
 end;
 
 {@@ ----------------------------------------------------------------------------