hyperlink2.pas

一个经典的读写Excel的控件

    Stream.ReadHeader(Header);
    Stream.Read(PBuf^,Header.Length);
    HLink.FToolTip := BufUnicodeZToWS(@PRecHLINKTOOLTIP(PBuf).Text,Header.Length - SizeOf(TRecHLINKTOOLTIP));
  end;
end;

procedure THyperlinks.SaveToStream(Stream: TXLSStream; PBuf: PByteArray);
const
  UnSequence: array[0..23] of byte = ($FF,$FF,$AD,$DE,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
var
  i,Sz: integer;
  DirUpCnt: word;
  S,Dos8_3: string;

function ZUCLen(WS: WideString): integer;
begin
  if WS <> '' then
    Result := Length(WS) * 2 + 2
  else
    Result := 0;
end;

procedure WriteUSZLen(WS: WideString; CharLen: boolean = True);
var
  L: longword;
  Z: word;
begin
  Z := 0;
  if CharLen then
    L := Length(WS) + 1
  else
    L := Length(WS) * 2 + 2;
  Stream.Write(L,4);
  Stream.Write(Pointer(WS)^,Length(WS) * 2);
  Stream.WWord(Z);
end;

begin
  for i := 0 to Count - 1 do begin
    if Items[i].FHyperlinkType = hltUnknown then begin
      Stream.WriteHeader(BIFFRECID_HLINK,Items[i].FBufLen);
      Stream.Write(Items[i].FBuf^,Items[i].FBufLen);
      Continue;
    end;

    if Items[i].FChanged then begin
      case Items[i].FHyperlinkEncoding of
        hleURL: begin
          Items[i].FOptions := Items[i].FOptions and not $0160;
          Items[i].FOptions := Items[i].FOptions or $0003;
        end;
        hleFile: begin
          Items[i].FOptions := Items[i].FOptions and not $0160;
          Items[i].FOptions := Items[i].FOptions or $0001;
        end;
        hleUNC: begin
          Items[i].FOptions := Items[i].FOptions and not $0060;
          Items[i].FOptions := Items[i].FOptions or $0103;
        end;
        hleWorkbook: begin
          Items[i].FOptions := Items[i].FOptions and not $0163;
          Items[i].FOptions := Items[i].FOptions or $0008;
        end;
      end;
      if Items[i].FDescription <> '' then
        Items[i].FOptions := Items[i].FOptions or $0014
      else
        Items[i].FOptions := Items[i].FOptions and not $0014;
    end;

    Sz := SizeOf(TRecHLINK);

    if Items[i].FDescription <> '' then
      Inc(Sz,4 + ZUCLen(Items[i].FDescription));
    if Items[i].FTargetFrame <> '' then
      Inc(Sz,4 + ZUCLen(Items[i].FTargetFrame));
    case Items[i].FHyperlinkEncoding of
      hleURL:
        Inc(Sz,16 + 4 + ZUCLen(Items[i].FAddress));
      hleFile: begin
        S := Items[i].FAddress;
        // The DOS file path will only be included if GetShortPathName can find
        // the disk file.
        SetLength(Dos8_3,255);
        SetLength(Dos8_3,GetShortPathName(PChar(S),PChar(Dos8_3),255));
        if Dos8_3 <> '' then
          Inc(Sz,16 + 2 + 4 + (Length(Dos8_3) + 1) + 24 + 4)
        else
          Inc(Sz,16 + 2 + 4 + 24 + 4);
        if Items[i].FAddress <> '' then
          Inc(Sz,4 + 2 + Length(Items[i].FAddress) * 2);
      end;
      hleUNC:
        Inc(Sz,4 + ZUCLen(Items[i].FAddress));
      hleWorkbook: ;
    end;
    if Items[i].FScreenTip <> '' then
      Inc(Sz,4 + ZUCLen(Items[i].FScreenTip));

    Stream.WriteHeader(BIFFRECID_HLINK,Sz);
    PRecHLINK(PBuf).Row1 := Items[i].FRow1;
    PRecHLINK(PBuf).Row2 := Items[i].FRow2;
    PRecHLINK(PBuf).Col1 := Items[i].FCol1;
    PRecHLINK(PBuf).Col2 := Items[i].FCol2;
    Move(GUID_STDLINK,PRecHLINK(PBuf).GUID,Length(GUID_STDLINK));
    PRecHLINK(PBuf).Reserved := $00000002;
    PRecHLINK(PBuf).Options := Items[i].FOptions;
    Stream.Write(PBuf^,SizeOf(TRecHLINK));
    if Items[i].FDescription <> '' then
      WriteUSZLen(Items[i].FDescription);
    if Items[i].FTargetFrame <> '' then
      WriteUSZLen(Items[i].FTargetFrame);
    case Items[i].FHyperlinkEncoding of
      hleURL: begin
        Stream.Write(GUID_URL,Length(GUID_URL));
        WriteUSZLen(Items[i].FAddress,False);
      end;
      hleFile: begin
        Stream.Write(GUID_FILE,Length(GUID_FILE));
        DirUpCnt := 0;
        while Copy(Items[i].FAddress,1,3) = '..\' do begin
          Inc(DirUpCnt);
          Items[i].FAddress := Copy(Items[i].FAddress,4,MAXINT);
        end;
        Stream.WWord(DirUpCnt);
        if Dos8_3 <> '' then begin
          Stream.WLWord(Length(Dos8_3) + 1);
          Stream.Write(Pointer(Dos8_3)^,Length(Dos8_3));
          Stream.WByte(0);
        end
        else
          Stream.WLWord(0);
        Stream.Write(UnSequence[0],Length(UnSequence));
        if Items[i].FAddress <> '' then begin
          Stream.WLWord(4 + 2 + Length(Items[i].FAddress) * 2);
          Stream.WLWord(Length(Items[i].FAddress) * 2);
          Stream.WByte($03);
          Stream.WByte($00);
          Stream.Write(Pointer(Items[i].FAddress)^,Length(Items[i].FAddress) * 2);
        end
        else
          Stream.WLWord(0);
      end;
      hleUNC: begin
        WriteUSZLen(Items[i].FAddress);
      end;
      hleWorkbook: begin
      end;
    end;
    if Items[i].FScreenTip <> '' then
      WriteUSZLen(Items[i].FScreenTip);

    if Items[i].FToolTip <> '' then begin
      Stream.WriteHeader(BIFFRECID_HLINKTOOLTIP,SizeOf(TRecHLINKTOOLTIP) + Length(Items[i].FToolTip) * 2 + 2);
      PRecHLINKTOOLTIP(PBuf).RecId := BIFFRECID_HLINKTOOLTIP;
      PRecHLINKTOOLTIP(PBuf).Row1 := Items[i].FRow1;
      PRecHLINKTOOLTIP(PBuf).Row2 := Items[i].FRow2;
      PRecHLINKTOOLTIP(PBuf).Col1 := Items[i].FCol1;
      PRecHLINKTOOLTIP(PBuf).Col2 := Items[i].FCol2;
      Stream.Write(PBuf^,SizeOf(TRecHLINKTOOLTIP));
      Stream.Write(Pointer(Items[i].FToolTip)^,Length(Items[i].FToolTip) * 2);
      Stream.WWord(0);
    end;

  end;
end;

{ THyperlink }

constructor THyperlink.Create(Collection: TCollection);
begin
  inherited Create(Collection);
end;

destructor THyperlink.Destroy;
begin
  if FBuf <> Nil then
    FreeMem(FBuf);
  inherited;
end;

procedure THyperlink.SetAddress(const Value: WideString);
var
  Buf: PByteArray;

function BeginWith(WS: WideString): boolean;
begin
  Result := AnsiLowercase(Copy(Value,1,Length(WS))) = WS;
end;

begin
  FScreenTip := '';
  if BeginWith('http://') or BeginWith('https://') or BeginWith('www.') or BeginWith('ftp://') then
    FHyperlinkType := hltURL
  else if BeginWith('mailto:') then
    FHyperlinkType := hltURL
  else if BeginWith('\\') then
    FHyperlinkType := hltUNC
  else begin
    try
      GetMem(Buf,255);
      try
        // If EncodeFormula can't parse the value as a formula, there will
        // be an exception, and the value is assumed to be a file.
        THyperlinks(Collection).FFormulaHandler.EncodeFormula(Value,Buf,255);
        FHyperlinkType := hltWorkbook;
        FScreenTip := '#' + Value;
      finally
        FreeMem(Buf);
      end;
    except
      FHyperlinkType := hltFile;
    end;
  end;
  FHyperlinkEncoding := THyperlinkEncoding(FHyperlinkType);
  FAddress := Value;
  FChanged := True;
end;

procedure THyperlink.SetDescription(const Value: WideString);
begin
  FDescription := Value;
  FChanged := True;
end;

procedure THyperlink.SetToolTip(const Value: WideString);
begin
  FToolTip := Value;
  FChanged := True;
end;

procedure THyperlink.StoreUnknown(Len: integer; PBuf: PByteArray);
begin
  FBufLen := Len;
  GetMem(FBuf,FBufLen);
  Move(PBuf^,FBuf^,FBufLen);
end;

end.