tmsuxlshyperlink.pas

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

begin
  if ((((OptionFlags and 3) = $03) and ((OptionFlags and $60) = 0)) and
    ((Self.OptionFlags and $100) = 0)) then
    begin
      Result := CompareMem(@URLGUID, PAddress(Data)+ pos,16);
      Exit;
    end;
  Result := False;
end;

function THLinkRecord.IsFile(pos: Integer): Boolean;
begin
  if ((((Self.OptionFlags and 1) = $01) and ((Self.OptionFlags and $60) = 0)) and
    ((Self.OptionFlags and $100) = 0)) then
    begin
      Result := CompareMem(@FILEGUID, PAddress(Data)+ pos,16);
      Exit;
    end;
  Result := False;
end;

function THLinkRecord.IsUNC(pos: Integer): Boolean;
begin
  Result := ((((Self.OptionFlags and $03) = $03) and ((Self.OptionFlags and $60) =0))
             and ((Self.OptionFlags and $100) <> 0));
end;

function THLinkRecord.GetText(var pos: Integer; var HType: THyperLinkType): UTF16String;
begin
  if IsUrl(pos) then
  begin
    HType := hl_URL;
    inc(Pos,16);
    Result := ReadString(pos, 0, 1);
    Exit;
  end;
  if IsFile(pos) then
  begin
    HType := hl_LocalFile;
    inc(Pos,16);
    Result := ReadLocalFile(pos);
    Exit;
  end;
  if IsUNC(pos) then
  begin
    HType := hl_UNC;
    Result := ReadString(pos, 0, 2);
    Exit;
  end;
  HType := hl_CurrentWorkbook;
  Result := '';
end;

procedure THLinkRecord.SetText(var pos: Integer; Text: UTF16String; HType: THyperLinkType);
begin
  case (HType) of
    hl_URL:
    begin
        OptionFlags:=(OptionFlags or $03) and not $160;
        SetString2(pos, @URLGUID, Text,1);
    end;

    hl_LocalFile:
    begin
        OptionFlags:=(OptionFlags or $01) and not $160;
        SetLocalFile(pos, Text);
    end;

    hl_UNC:
    begin
        OptionFlags:=(OptionFlags or $103) and not $60;
        SetString2(pos, nil, Text,2);
    end;

    hl_CurrentWorkbook:
    begin
        OptionFlags:=(OptionFlags) and not $163;
        //No SetString2(pos, nil, '', 1);
    end;
  end; //case
end;

function THLinkRecord.GetProperties: THyperLink;
var
  TmpLinkType: THyperLinkType;
  pos: Integer;
begin
  pos := 32;
  Result.Description := ReadString(pos, $14, 2);
  Result.TargetFrame := ReadString(pos, $80, 2);
  TmpLinkType := hl_CurrentWorkbook;
  Result.Text := GetText(pos, TmpLinkType);
  Result.LinkType := TmpLinkType;
  Result.TextMark := ReadString(pos, $8, 2);
  if (Hint = nil) then
    Result.Hint := ''
  else
    Result.Hint := Hint.Text;
end;

procedure THLinkRecord.ClearData;
begin
  DataSize:=32;
  ReallocMem(Data,DataSize);
  FillChar(Data[28],4,0);
end;

procedure THLinkRecord.SetProperties(value: THyperLink);
var
  pos: Integer;
begin
  ClearData;
  pos := 32;
  SetString(pos, $14, value.Description);
  SetString(pos, $80, value.TargetFrame);
  SetText(pos, value.Text, value.LinkType);
  SetString(pos, $8, value.TextMark);
  if (value.Hint = '') then
    FreeAndNil(Hint)
  else
    if (Hint = nil) then
      Hint := TScreenTipRecord.CreateNew(value.Hint)
    else
      Hint.Text := value.Hint;
end;

function THLinkRecord.GetCellRange: TXlsCellRange;
begin
  Result.Top:=FirstRow;
  Result.Left:=FirstCol;
  Result.Bottom:=LastRow;
  Result.Right:=LastCol;
end;

procedure THLinkRecord.SetCellRange(CellRange: TXlsCellRange);
begin
  FirstRow := CellRange.Top;
  FirstCol := CellRange.Left;
  LastRow := CellRange.Bottom;
  LastCol := CellRange.Right;
end;

procedure THLinkRecord.ArrangeInsertRange(CellRange: TXlsCellRange; aRowCount: Integer;
  aColCount: Integer; SheetInfo: TSheetInfo);
begin
  //Hyperlink data doesn't move when you insert/copy cells or sheets. It is a static text.

  if ((SheetInfo.InsSheet < 0) or (SheetInfo.FormulaSheet <> SheetInfo.InsSheet)) then
    Exit;
  if (((aRowCount <> 0) and (FirstCol >= CellRange.Left)) and (LastCol <= CellRange.Right)) then
  begin
    if (FirstRow >= CellRange.Top) then
      IncWord(Data, 0, (aRowCount * (CellRange.Bottom-CellRange.Top+1)), Max_Rows);
    if (LastRow >= CellRange.Top) then
      IncWord(Data, 2, (aRowCount * (CellRange.Bottom-CellRange.Top+1)), Max_Rows);
  end;
  if (((aColCount <> 0) and (FirstRow >= CellRange.Top)) and (LastRow <= CellRange.Bottom)) then
  begin
    if (FirstCol >= CellRange.Left) then
      IncWord(Data, 4, (aColCount * (CellRange.Right-CellRange.Left+1)), Max_Columns);
    if (Self.LastCol >= CellRange.Left) then
      IncWord(Data, 6, (aColCount * (CellRange.Right-CellRange.Left+1)), Max_Columns);
  end;
end;

function THLinkRecord.Offset(DeltaRow: Integer; DeltaCol: Integer): THLinkRecord;
begin
  FirstRow:= FirstRow + DeltaRow;
  LastRow:= LastRow + DeltaRow;
  FirstCol:= FirstCol + DeltaCol;
  LastCol:= LastCol + DeltaCol;

  Result := Self;
end;

{ TScreenTipRecord }

constructor TScreenTipRecord.Create(const aId: word; const aData: PArrayOfByte; const aDataSize: integer);
begin
  inherited Create(aId, aData, aDataSize);
end;

constructor TScreenTipRecord.CreateNew(aDescription: UTF16String);
begin
   Create(xlr_SCREENTIP, nil, 0);
   Text := aDescription;
end;


function TScreenTipRecord.GetFirstRow: Integer;
begin
  Result := GetWord(Data, 2);
end;

function TScreenTipRecord.GetLastRow: Integer;
begin
  Result := GetWord(Data, 4);
end;

function TScreenTipRecord.GetFirstCol: Integer;
begin
  Result := GetWord(Data, 6);
end;

function TScreenTipRecord.GetLastCol: Integer;
begin
  Result := GetWord(Data, 8);
end;

function TScreenTipRecord.GetText: UTF16String;
begin
  SetLength(Result, (DataSize-10-2)div 2);
  move(Data[10], Result[1], Length(Result)*2);
end;

procedure TScreenTipRecord.SetFirstRow(Value: Integer);
begin
  SetWord(Data, 2, value);
end;

procedure TScreenTipRecord.SetLastRow(Value: Integer);
begin
  SetWord(Data, 4, value);
end;

procedure TScreenTipRecord.SetFirstCol(Value: Integer);
begin
  SetWord(Data, 6, value);
end;

procedure TScreenTipRecord.SetLastCol(Value: Integer);
begin
  SetWord(Data, 8, value);
end;

procedure TScreenTipRecord.SetText(Value: UTF16String);
begin
  FreeAndNil(Data);
  DataSize:=12+Length(Value)*2;
  GetMem(Data, DataSize);
  FillChar(Data[0],DataSize,0);
  move(Value[1], Data[10], Length(Value)*2);
  SetWord(Data, 0, 2048);
end;

{ THLinkList }
procedure THLinkList.CopyFrom(aHLinkList: THLinkList);
var
  i: Integer;
begin
  for i := 0 to aHLinkList.Count-1 do
  begin
    Add(aHLinkList[i].CopyTo as THLinkRecord);
  end;
end;

procedure THLinkList.CopyObjectsFrom(aHLinkList: THLinkList; CopyRange: TXlsCellRange;
  RowOfs: Integer; ColOfs: Integer);
var
  r: THLinkRecord;
  i: Integer;
begin
  if (aHLinkList = nil) then exit;
  for i := 0 to aHLinkList.Count-1 do
  begin
    r := aHLinkList[i];
    if ((((r.FirstCol >= CopyRange.Left) and (r.LastCol <= CopyRange.Right))
    and (r.FirstRow >= CopyRange.Top)) and (r.LastRow <= CopyRange.Bottom)) then
        Add((THLinkRecord(r.CopyTo)).Offset(RowOfs, ColOfs));
  end;
end;

procedure THLinkList.SaveToStream(DataStream: TOle2File);
var
  i: Integer;
begin
  Sort;
  for i := 0 to Count-1 do
  begin
    Items[i].SaveToStream(DataStream);
  end;
end;

procedure THLinkList.SaveRangeToStream(DataStream: TOle2File; CellRange: TXlsCellRange);
var
  i: Integer;
begin
  Sort;
  for i := 0 to Count-1 do
  begin
    Items[i].SaveRangeToStream(DataStream, CellRange);
  end;
end;

function THLinkList.TotalSize: Int64;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to Count-1 do
    inc(Result, Items[i].TotalSize);
end;

function THLinkList.TotalRangeSize(CellRange: TXlsCellRange): Int64;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to Count-1 do
    inc(Result, Items[i].TotalRangeSize(CellRange));
end;

procedure THLinkList.InsertAndCopyRange(SourceRange: TXlsCellRange; DestRow: Integer;
  DestCol: Integer; aRowCount: Integer; aColCount: Integer; SheetInfo: TSheetInfo);
var
  cc: Integer;
  rc: Integer;
  r: THLinkRecord;
  i: Integer;
  RBottom: Integer;
  RRight: Integer;
  RLeft: Integer;
  RTop: Integer;
  SourceRangeRowCount: integer;
  SourceRangeColCount: integer;
begin
  SourceRangeRowCount:=SourceRange.Bottom-SourceRange.Top+1;
  SourceRangeColCount:=SourceRange.Right-SourceRange.Left+1;

  for i:=0 to Count-1 do
  begin
    Items[i].ArrangeInsertRange(OffsetRange(SourceRange, DestRow, DestCol), aRowCount, aColCount, SheetInfo);
  end;

  //Pending:  if (CopyMode = TRangeCopyMode.None) then exit;
  RTop := SourceRange.Top;
  RLeft := SourceRange.Left;
  if (DestRow <= SourceRange.Top) then inc(RTop, aRowCount* SourceRangeRowCount);
  if (DestCol <= SourceRange.Left) then inc(RLeft, aColCount* SourceRangeColCount);
  RRight := ((RLeft + SourceRangeColCount) - 1);
  RBottom := ((RTop + SourceRangeRowCount) - 1);

  if ((aRowCount > 0) or (aColCount > 0)) then
    begin
      for i:=0 to Count-1 do
      begin
        r := Items[i];
        if (r.FirstCol >= RLeft) and (r.LastCol <= RRight) and (r.FirstRow>= RTop) and (r.LastRow <= RBottom) then
        begin
          for rc:=0 to aRowCount-1 do
          begin
            Add(THLinkRecord(r.CopyTo).Offset(DestRow - RTop + rc * SourceRangeRowCount, DestCol - RLeft));
          end;
          for cc:=0 to aColCount-1 do
          begin
            Add(THLinkRecord(r.CopyTo).Offset(DestRow - RTop,DestCol - RLeft + cc * SourceRangeColCount));
          end;
        end;
      end;
    end;
end;

procedure THLinkList.DeleteRange(CellRange: TXlsCellRange; aRowCount: Integer;
  aColCount: Integer; SheetInfo: TSheetInfo);
var
  bColCount: Integer;
  bRowCount: Integer;
  r: THLinkRecord;
  i: Integer;
  CellRangeRowCount: integer;
  CellRangeColCount: integer;
begin
  CellRangeRowCount:=CellRange.Bottom-CellRange.Top+1;
  CellRangeColCount:=CellRange.Right-CellRange.Left+1;
  for i:= Count-1 downto 0 do
  begin
    r := Items[i];
    bRowCount := (aRowCount - 1);if (bRowCount < 0) then bRowCount := 0;
    bColCount := (aColCount - 1);if (bColCount < 0) then bColCount := 0;

    if (r.FirstRow >= CellRange.Top) and (r.LastRow <= CellRange.Bottom +
      CellRangeRowCount * bRowCount) and (r.FirstCol >= CellRange.Left)
      and (r.LastCol <= CellRange.Right + CellRangeColCount * bColCount) then
      Delete(i)
    else
    begin
      r.ArrangeInsertRange(CellRange, -aRowCount, -aColCount, SheetInfo);
      if (r.LastRow < r.FirstRow) then
        Delete(i);
    end;
  end;
end;

procedure THLinkRecord.AddHint(const aHint: TScreenTipRecord);
begin
  FreeAndNil(Hint);
  Hint:=aHint;
end;

destructor THLinkRecord.Destroy;
begin
  FreeAndNil(Hint);
  inherited;
end;

end.