tmsuxlshyperlink.pas

TMS Component Pack V5.0包含了超过 280 个为 Delphi 以及 C++Builder 设计的 TMS 生产控件

unit tmsUXlsHyperLink;
{$INCLUDE ..\FLXCOMPILER.INC}
{$INCLUDE ..\FLXCONFIG.INC}

interface
uses Classes, SysUtils, tmsUXlsBaseRecords, tmsXlsMessages, tmsUFlxMessages, tmsUXlsBaseList, tmsUOle2Impl;

type
  TScreenTipRecord=class;

  THLinkRecord = class(TBaseRecord)
  private
    Hint: TScreenTipRecord;

    function ReadString(var Pos: Integer; const OptMask: Integer; const ByteSize: Integer): UTF16String;
    function ReadLocalFile(var Pos: Integer): UTF16String;
    procedure SetString(var Pos: Integer; const OptMask: Integer; const value: UTF16String);
    procedure SetString2(var Pos: Integer; const GUID: PArrayOfByte; const value: UTF16String; const ByteCount: Integer);
    procedure SetLocalFile(var Pos: Integer; const value: UTF16String);
    function IsUrl(pos: Integer): Boolean;
    function IsFile(pos: Integer): Boolean;
    function IsUNC(pos: Integer): Boolean;
    function GetText(var pos: Integer; var HType: THyperLinkType): UTF16String;
    procedure SetText(var pos: Integer; Text: UTF16String; HType: THyperLinkType);
    procedure ClearData;

    function GetFirstRow: Integer;
    function GetLastRow: Integer;
    function GetFirstCol: Integer;
    function GetLastCol: Integer;
    function GetOptionFlags: Integer;
    procedure SetFirstRow(Value: Integer);
    procedure SetLastRow(Value: Integer);
    procedure SetFirstCol(Value: Integer);
    procedure SetLastCol(Value: Integer);
    procedure SetOptionFlags(Value: Integer);

  protected
    function DoCopyTo: TBaseRecord; override;
  public
    procedure AddHint(const aHint: TScreenTipRecord);
    constructor Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);override;
    constructor CreateNew(const CellRange: TXlsCellRange; const HLink: THyperLink);
    destructor Destroy;override;

    property FirstRow: Integer read GetFirstRow write SetFirstRow;
    property LastRow: Integer read GetLastRow write SetLastRow;
    property FirstCol: Integer read GetFirstCol write SetFirstCol;
    property LastCol: Integer read GetLastCol write SetLastCol;
    property OptionFlags: Integer read GetOptionFlags write SetOptionFlags;

    procedure SaveToStream(const Workbook: TOle2File);override;
    procedure SaveRangeToStream(const Workbook: TOle2File; const CellRange: TXlsCellRange);
    function TotalRangeSize(const CellRange: TXlsCellRange): Integer;

    function TotalSize: Integer;override;
    function TotalSizeNoHeaders: Integer;override;

    function GetProperties: THyperLink;
    procedure SetProperties(value: THyperLink);
    function GetCellRange: TXlsCellRange;
    procedure SetCellRange(CellRange: TXlsCellRange);

    procedure ArrangeInsertRange(CellRange: TXlsCellRange; aRowCount: Integer; aColCount: Integer; SheetInfo: TSheetInfo);
    function Offset(DeltaRow: Integer; DeltaCol: Integer): THLinkRecord;

  end;

  TScreenTipRecord = class(TBaseRecord)
  protected
    function GetFirstRow: Integer;
    function GetLastRow: Integer;
    function GetFirstCol: Integer;
    function GetLastCol: Integer;
    function GetText: UTF16String;
    procedure SetFirstRow(Value: Integer);
    procedure SetLastRow(Value: Integer);
    procedure SetFirstCol(Value: Integer);
    procedure SetLastCol(Value: Integer);
    procedure SetText(Value: UTF16String);

  public
    constructor Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);  override;
    constructor CreateNew(aDescription: UTF16String);

    property FirstRow: Integer read GetFirstRow write SetFirstRow;
    property LastRow: Integer read GetLastRow write SetLastRow;
    property FirstCol: Integer read GetFirstCol write SetFirstCol;
    property LastCol: Integer read GetLastCol write SetLastCol;
    property Text: UTF16String read GetText write SetText;
  end;

  THLinkList = class(TBaseList)
  {$INCLUDE THLinkListHdr.inc}
  public
    procedure CopyFrom(aHLinkList: THLinkList);
    procedure CopyObjectsFrom(aHLinkList: THLinkList; CopyRange: TXlsCellRange; RowOfs: Integer; ColOfs: Integer);
    procedure SaveToStream(DataStream: TOle2File);
    procedure SaveRangeToStream(DataStream: TOle2File; CellRange: TXlsCellRange);
    function TotalSize: Int64;
    function TotalRangeSize(CellRange: TXlsCellRange): Int64;
    procedure InsertAndCopyRange(SourceRange: TXlsCellRange; DestRow: Integer;
      DestCol: Integer; aRowCount: Integer; aColCount: Integer; SheetInfo: TSheetInfo);
    procedure DeleteRange(CellRange: TXlsCellRange; aRowCount: Integer; aColCount: Integer;
      SheetInfo: TSheetInfo);
  end;

implementation
{$INCLUDE THLinkListImp.inc}

const
  FILEGUID: array [0..15] of byte=($03, $03, $00, $00, $00, $00, $00, $00, $C0, $00, $00, $00, $00, $00, $00, $46);
  URLGUID: array [0..15] of byte=($E0, $C9, $EA, $79, $F9, $BA, $CE, $11, $8C, $82, $00, $AA, $00, $4B, $A9, $0B);

constructor THLinkRecord.Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);
begin
  inherited Create(aId, aData, aDataSize);
  Hint := nil;
end;

function THLinkRecord.GetFirstRow: Integer;
begin
  Result := GetWord(Data, 0);
end;

function THLinkRecord.GetLastRow: Integer;
begin
  Result := GetWord(Data, 2);
end;

function THLinkRecord.GetFirstCol: Integer;
begin
  Result := GetWord(Data, 4);
end;

function THLinkRecord.GetLastCol: Integer;
begin
  Result := GetWord(Data, 6);
end;

function THLinkRecord.GetOptionFlags: Integer;
begin
  Result := GetWord(Data, 28);
end;

procedure THLinkRecord.SetFirstRow(Value: Integer);
begin
  SetWord(Data, 0, value);
end;

procedure THLinkRecord.SetLastRow(Value: Integer);
begin
  SetWord(Data, 2, value);
end;

procedure THLinkRecord.SetFirstCol(Value: Integer);
begin
  SetWord(Data, 4, value);
end;

procedure THLinkRecord.SetLastCol(Value: Integer);
begin
  SetWord(Data, 6, value);
end;

procedure THLinkRecord.SetOptionFlags(Value: Integer);
begin
  SetWord(Data, 28, value);
end;

constructor THLinkRecord.CreateNew(const CellRange: TXlsCellRange; const HLink: THyperLink);
var
  TmpData: PArrayOfByte;
begin
  GetMem(TmpData, 32);
  FillChar(TmpData[0], 32, 0);
  try
    inherited Create(xlr_HLINK, TmpData, 32);
    TmpData:=nil;

    FirstRow := CellRange.Top;
    FirstCol := CellRange.Left;
    LastRow := CellRange.Bottom;
    LastCol := CellRange.Right;
    SetLongWord(Data, 8, $79EAC9D0);
    SetLongWord(Data, 12, $11CEBAF9);
    SetLongWord(Data, 16, $AA00828C);
    SetLongWord(Data, 20, $0BA94B00);
    SetWord(Data, 24, 2);
    FillChar(Data[26],6,0);
    SetProperties(HLink);
  finally
    FreeAndNil(TmpData);
  end; //finally
end;

procedure THLinkRecord.SaveToStream(const Workbook: TOle2File);
begin
  inherited SaveToStream(Workbook);
  if (Hint <> nil) then
  begin
    Hint.FirstRow := FirstRow;
    Hint.FirstCol := FirstCol;
    Hint.LastRow := LastRow;
    Hint.LastCol := LastCol;
    Hint.SaveToStream(Workbook);
  end;
end;

procedure THLinkRecord.SaveRangeToStream(const Workbook: TOle2File; const CellRange: TXlsCellRange);
begin
  if ((((Self.FirstRow > CellRange.Bottom) or (Self.LastRow < CellRange.Top))
    or (Self.FirstCol > CellRange.Right)) or (Self.LastCol < CellRange.Left)) then
    exit;
  SaveToStream(Workbook);
end;

function THLinkRecord.TotalRangeSize(const CellRange: TXlsCellRange): Integer;
begin
  if ((((Self.FirstRow > CellRange.Bottom) or (Self.LastRow < CellRange.Top))
    or (Self.FirstCol > CellRange.Right)) or (Self.LastCol < CellRange.Left)) then
    begin
      Result := 0;
      exit;
    end;
  Result := TotalSize;
end;

function THLinkRecord.DoCopyTo: TBaseRecord;
begin
  Result := inherited DoCopyTo;
  if (Hint <> nil) then
    (Result as THLinkRecord).Hint := Hint.CopyTo as TScreenTipRecord;
end;

function THLinkRecord.TotalSize: Integer;
begin
  Result := inherited TotalSize;
  if (Hint <> nil) then
    inc(Result, Hint.TotalSize);
end;

function THLinkRecord.TotalSizeNoHeaders: Integer;
begin
  Result := inherited TotalSizeNoHeaders;
  if (Hint <> nil) then
    inc(Result, Hint.TotalSizeNoHeaders);
end;

function THLinkRecord.ReadString(var Pos: Integer; const OptMask: Integer; const ByteSize: Integer): UTF16String;
var
  OldPos: Integer;
  p: integer;
begin
  if ((OptionFlags and OptMask) <> OptMask) then
  begin
    Result := '';
  end
  else
  begin
    OldPos := Pos;
    inc(Pos, 4+Integer(GetLongWord(Data, Pos))*ByteSize);
    SetLength(Result, (Pos-(OldPos+4)-2) div 2); //00 Terminated
    move(Data[OldPos+4], Result[1], Length(Result)*2);
    p := System.Pos(#0, Result);
    if (p > 0) then Delete(Result, p, Length(Result)); //string might have a 0 inside. In this case we need to cut it.
  end;
end;

function THLinkRecord.ReadLocalFile(var Pos: Integer): UTF16String;
var
  XLen: Integer;
  RLen: Integer;
  s8: AnsiString;
  s16: UTF16String;
  StrLen: Integer;
  i: Integer;
  DirUp: Integer;
begin
  Result := '';
  DirUp := GetWord(Data, Pos);

  for i:=0 to DirUp-1 do
    Result:=Result+ IncludeTrailingPathDelimiter('..');

  inc(Pos,2);
  StrLen := GetLongWord(Data, Pos);
  if (StrLen > 1) then Dec(StrLen);

  SetLength(s8, StrLen);
  move(Data[Pos+4], s8[1], StrLen);
  inc(Pos, 4+StrLen+1+24);

  RLen := GetLongWord(Data, Pos);
  inc(Pos,4);
  if (RLen = 0) then
  begin
    Result:=Result+ StringToWideStringNoCodePage(s8);
    Exit;
  end;

  XLen := GetLongWord(Data, Pos);
  inc(Pos, 4+2);
  SetLength(s16, XLen div 2);
  move(Data[Pos], s16[1], XLen);
  inc(Pos, XLen);
  Result := Result+s16;
end;

procedure THLinkRecord.SetString(var Pos: Integer; const OptMask: Integer; const value: UTF16String);
var
  Len: Integer;
begin
  if (value= '') then
  begin
    if ((OptionFlags and OptMask) <> OptMask) then Exit; //Already empty
    OptionFlags:=OptionFlags and not OptMask;

    DataSize:=DataSize-4-Integer(GetLongWord(Data, Pos))*2;
    ReallocMem(Data, DataSize);
  end
  else
  begin
    Len := 0;
    if ((Self.OptionFlags and OptMask) = OptMask) then Len := 4 + GetLongWord(Data, Pos) * 2;
    DataSize:=DataSize-Len+4+Length(Value)*2+2;
    ReallocMem(Data, DataSize);
    if (Pos+1<DataSize) then FillChar(Data[Pos+1], DataSize-Pos-1, 0);

    SetLongWord(Data, Pos, Length(Value) + 1);
    move(value[1], Data[Pos+4] , Length(Value)* 2);
    inc(Pos, 4+Length(Value)*2+2);
    SetWord(Data, Pos-2, 0);

    OptionFlags := OptionFlags or OptMask;
  end;
end;

procedure THLinkRecord.SetString2(var Pos: Integer; const GUID: PArrayOfByte; const value: UTF16String; const ByteCount: Integer);
var
  GuidSize: integer;
begin
  if GUID=nil then GuidSize:=0 else GuidSize:=16;
  DataSize:=DataSize +GuidSize+ 4+ Length(Value)*2 + 2;
  ReallocMem(Data, DataSize);
  if (Pos+1<DataSize) then FillChar(Data[Pos+1], DataSize-Pos-1, 0);

  if (GUID<>nil) then
  begin
    move(GUID[0], Data[Pos], 16);
    inc(Pos, 16);
  end;
  SetLongWord(Data, Pos, ((Length(value)*2 + 2) div ByteCount));
  move(value[1], Data[Pos+4] , Length(Value)* 2);
  inc(Pos, 4+ Length(Value)*2+2);
  SetWord(Data, Pos-2 ,0);
end;

procedure THLinkRecord.SetLocalFile(var Pos: Integer; const value: UTF16String);
var
  WideDataLen: Integer;
  IsCompressed: Boolean;
  i: Integer;
  NewValue: UTF16String;
begin
  i := 0;
  while copy(value,i+1, 3) = IncludeTrailingPathDelimiter('..') do inc(i,3);

  NewValue := copy(value, i+1, Length(Value));
  IsCompressed := not IsWide(NewValue);
  WideDataLen := 0;
  if (not IsCompressed) then
  begin
    WideDataLen := 4+4+2+Length(NewValue)*2;
  end;

  DataSize:=DataSize+16+2+4+Length(NewValue)+1+24+4+WideDataLen;
  ReallocMem(Data, DataSize);
  if (Pos+1<DataSize) then FillChar(Data[Pos+1], DataSize-Pos-1, 0);
  move(FILEGUID[0], Data[Pos], 16);
  inc(Pos,16);
  SetWord(Data, Pos, (i div 3));
  inc (Pos, 2);
  SetLongWord(Data, Pos, Length(NewValue) + 1);
  inc(Pos,4);
  CompressBestUnicode(NewValue, Data, Pos);
  inc(Pos, Length(NewValue) + 1);
  Data[Pos-1]:=0;

  FillChar(Data[Pos], 24, 0);
  SetLongWord(Data, Pos, $DEADFFFF);
  inc(Pos,24);
  if IsCompressed then
  begin
    Exit;
  end;

  SetLongWord(Data, Pos, ((4 + 2) + Length(NewValue)*2));
  inc(Pos,4);
  SetLongWord(Data, Pos, Length(NewValue)*2);
  inc(Pos,4);
  SetWord(Data, Pos, 3);
  inc(Pos,2);
  move(NewValue[1], Data[Pos] , Length(NewValue)* 2);
  inc(Pos, Length(NewValue)* 2);
end;

function THLinkRecord.IsUrl(pos: Integer): Boolean;