xlsnames2.pas

一个经典的读写Excel的控件

destructor TExtNameName.Destroy;
begin
  SetLength(FNameDef,0);
  inherited;
end;

function TExtNameName.NameType: TExtNameType;
begin
  Result := entName;
end;

procedure TExtNameName.WriteRecords(Stream: TXLSStream);
begin
  // Options(2) + Reserved(4) + Len name(1) + Name(x) + Len name def(2) + Name def(x)
  Stream.WriteHeader(BIFFRECID_EXTERNNAME,2 + 4 + 1 + Length(FName) + 2 + Length(FNameDef));
  Stream.WWord(FOptions);
  Stream.WWord(0);
  Stream.WWord(0);
  Stream.WriteUnicodeStr8(FName);
  Stream.WWord(Length(FNameDef));
  if Length(FNameDef) > 0 then
    Stream.Write(FNameDef[0],Length(FNameDef));
end;

{ TExtName }

constructor TExtName.Create(var P: PRecEXTERNNAME8);
begin
  FOptions := P.Options;
  FName := ExcelStrToString(@P.Data[0],P.LenName);
  if FName[1] = #1 then
    P := PRecEXTERNNAME8(Integer(P) + P.LenName * 2 + 8)
  else
    P := PRecEXTERNNAME8(Integer(P) + P.LenName + 8);
end;

function TExtName.GetName: string;
begin
  Result := Copy(FName,2,MAXINT);
end;

{ TExtNameDDE }

constructor TExtNameDDE.Create(P: PRecEXTERNNAME8);
begin
  inherited Create(P);
end;

destructor TExtNameDDE.Destroy;
begin
  FreeMem(FOPER);
  inherited;
end;

function TExtNameDDE.NameType: TExtNameType;
begin
  Result := entDDE;
end;

procedure TExtNameDDE.WriteRecords(Stream: TXLSStream);
begin
  // Options(2) + Reserved(4) + Len name(1) + Name(x)
  Stream.WriteHeader(BIFFRECID_EXTERNNAME,2 + 4 + 1 + Length(FName));
  Stream.WWord(FOptions);
  Stream.WWord(0);
  Stream.WWord(0);
  Stream.WriteUnicodeStr8(FName);
end;

{ TExtNameOLE }

constructor TExtNameOLE.Create(P: PRecEXTERNNAME8);
begin
  inherited Create(P);
end;

function TExtNameOLE.NameType: TExtNameType;
begin
  Result := entOLE;
end;

procedure TExtNameOLE.WriteRecords(Stream: TXLSStream);
begin
  // Options(2) + Reserved(4) + Len name(1) + Name(x)
  Stream.WriteHeader(BIFFRECID_EXTERNNAME,2 + 4 + 1 + Length(FName));
  Stream.WWord(FOptions);
  Stream.Write(FOLE2Id,4);
  Stream.WriteUnicodeStr8(FName);
end;

{ TInternalNamesList }

function TInternalNames.Add: TInternalName;
begin
  Result := TInternalName(inherited Add);
end;

procedure TInternalNames.AddBuiltInName(NameId: TBuiltInName;
  Sheet: integer; Definition: TDynByteArray);
var
  i: integer;
  S: string;

function SetData(N: TInternalName): TInternalName;
begin
  N.Options := $0020;
  N.SheetIndex := Sheet;
  N.NameName := S;
  N.NameDef := Definition;
  Result := N;
end;

begin
  S := #0 + Char(NameId);
  Inc(Sheet);
  for i := 0 to Count - 1 do begin
    if (Items[i].SheetIndex = Sheet) and (Items[i].NameName = S) then begin
      SetData(Items[i]);
      Exit;
    end;
  end;
  SetData(Add);
end;

function TInternalNames.AddWorkbookArea(AName, Formula: WideString): boolean;
begin
  Result := FindName(AName) < 0;
  if not Result then
    Exit;
  try
    with Add do begin
      Name := AName;
      Definition := Formula;
//    SheetIndex :=
      BuiltInName := bnNone;
    end;
  except
    Delete(Count - 1);
  end;
end;

constructor TInternalNames.Create(AOwner: TPersistent; GetNameMethod: TGetNameEvent; Encoder: TEncodeFormula);
begin
  inherited Create(TInternalName);
  FGetNameMethod := GetNameMethod;
  FEncoder := Encoder;
  FOwner := AOwner;
end;

procedure TInternalNames.DeleteBuiltIn(BuiltInName: TBuiltInName; SheetIndex,ExcludeIndex: integer);
var
  i: integer;
begin
  for i := 0 to Count - 1 do begin
    if (i <> ExcludeIndex) and (TBuiltInName(Items[i].FName[2]) = BuiltInName) and (Items[i].FSheetIndex = SheetIndex) then begin
      Delete(i);
      Exit;
    end;
  end;
end;

destructor TInternalNames.Destroy;
begin
  inherited;
end;

function TInternalNames.FindName(AName: WideString): integer;
var
  WS,WS2: WideString;
begin
{$ifdef ver130}
  WS := AnsiLowercase(AName);
{$else}
  WS := WideLowercase(AName);
{$endif}
  for Result := 0 to Count - 1 do begin
    WS2 := TInternalName(inherited Items[Result]).Name;
{$ifdef ver130}
    if AnsiLowercase(WS2) = WS then
{$else}
    if WideLowercase(WS2) = WS then
{$endif}
      Exit;
  end;
  Result := -1;
end;

function TInternalNames.FindUniqueName: string;
var
  N: integer;
begin
  if Count > 0 then
    N := TInternalName(inherited Items[Count - 1]).ID + 1
  else
    N := 1;
  repeat
    Result := #0 + 'Name' + IntToStr(N);
    Inc(N);
  until (FindName(Result) < 0);
end;

function TInternalNames.GetItems(Index: integer): TInternalName;
begin
  Result := TInternalName(inherited Items[Index]);
end;

function TInternalNames.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

procedure TInternalNames.SetNAME(P: PRecNAME);
begin
  Add.Set_NAME(P);
end;

procedure TInternalNames.WriteRecords(Stream: TXLSStream);
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    Items[i].WriteRecords(Stream);
end;

{ TInternalName }

constructor TInternalName.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  SetLength(FNameDef,0);
  DisplayName := TInternalNames(Collection).FindUniqueName;
end;

procedure TInternalName.DefineProperties(Filer: TFiler);
begin
  inherited;
  Filer.DefineProperty('NameDef',ReadPropNameDef,WritePropNameDef,True);
  Filer.DefineProperty('NameName',ReadPropNameName,WritePropNameName,True);
end;

destructor TInternalName.Destroy;
begin
  SetLength(FNameDef,0);
  inherited;
end;

function TInternalName.GetBuiltInName: TBuiltInName;
begin
  if (Length(FName) = 2) and (FName[2] in [#0..Char(Ord(bnNone) - 1)]) then
    Result := TBuiltInName(FName[2])
  else
    Result := bnNone;
end;

function TInternalName.GetDefinition: string;
var
  P: PByteArray;
begin
  if Length(FNameDef) > 0 then begin
    GetMem(P,512);
    try
      Move(FNameDef[0],P^,Length(FNameDef));
      Result := DecodeFmla(xvExcel97,P,Length(FNameDef),0,0,0,TInternalNames(Collection).FGetNameMethod)
    finally
      FreeMem(P);
    end;
  end
  else
    Result := '';
end;

function TInternalName.GetName: WideString;
begin
  if Length(FName) < 4 then
    Result := ''
  else begin
    if FName[1] = #0 then
      Result := Copy(FName,2,MAXINT)
    else begin
      SetLength(Result,(Length(FName) - 1) div 2);
      Move(FName[2],Pointer(Result)^,Length(FName) - 1);
    end;
  end;
end;

procedure TInternalName.ReadPropNameName(Reader: TReader);
var
  i,p: integer;
  S: string;
begin
  S := Reader.ReadString;
  SetLength(FName,Length(S) div 2);
  p := 1;
  for i := 1 to Length(FName) do begin
    FName[i] := Char(HexToByte(Copy(S,p,2)));
    Inc(p,2);
  end;
end;

procedure TInternalName.ReadPropNameDef(Reader: TReader);
var
  S: string;
begin
  S := Reader.ReadString;
  HexStringToDynByteArray(S,FNameDef);
end;

procedure TInternalName.SetBuiltInName(const Value: TBuiltInName);
begin
  if Value < bnNone then begin
    FOptions := FOptions or $0020;
    FName := #0 + Char(Value);
  end
  else
    FOptions := FOptions and not $0020;
end;

procedure TInternalName.SetDefinition(const Value: string);
var
  P: PbyteArray;
  Sz: integer;
begin
  if Length(FName) < 2 then
    raise Exception.Create('Name must be set before definition.');
  GetMem(P,512);
  try
    Sz := TInternalNames(Collection).FEncoder.Encode(Value,P,512);
    SetLength(FNameDef,Sz);
    Move(P^,FNameDef[0],Sz);
    // TODO More built in names can only be defined once.
    if (FOptions and $0020) = $0020 then begin
      case TBuiltInName(FName[2]) of
        bnPrintTitles: begin
          if not NameIsArea then
            raise Exception.Create('Name definition must be an area');
          FSheetIndex := TInternalNames(Collection).FEncoder.LastSheetIndex + 1;
          TInternalNames(Collection).DeleteBuiltIn(bnPrintTitles,FSheetIndex,Index);
        end;
      end;
    end
  finally
    FreeMem(P);
  end;
end;

procedure TInternalName.SetName(const Value: WideString);
begin
  if Length(Value) < 3 then
    raise Exception.Create(ersNameToShort);
  if TInternalNames(Collection).FindName(Value) >= 0 then
    raise Exception.Create(ersThereIsAllreadyAnAreaNamed);
  SetLength(FName,Length(Value) * 2);
  Move(Pointer(Value)^,Pointer(FName)^,Length(Value) * 2);
  FName := #1 + FName;
end;

procedure TInternalName.Set_NAME(P: PRecNAME);
var
  Ptr: PByteArray;

function GetString(var P: PByteArray; Len: integer): string;
var
  Sz: integer;
begin
  if P[0] = 0 then
    Sz := Len + 1
  else
    Sz := Len * 2 + 1;
  SetLength(Result,Sz);
  Move(P^,Pointer(Result)^,Sz);
  P := PByteArray(Integer(P) + Sz);
end;

begin
  FOptions := P.Options;
  FKeyShortcut := P.KeyShortcut;
  // Yes, they shall be exchanged. Sort this out some time...
  FSheetIndex := P.TabIndex;
  FTabIndex := P.SheetIndex;
  Ptr := @P.Data;
  FName := GetString(Ptr,P.LenName);
  SetLength(FNameDef,P.LenNameDef);
  Move(Ptr^,FNameDef[0],P.LenNameDef);
  Ptr := PByteArray(Integer(Ptr) + P.LenNameDef);
  if P.LenCustMenu > 0   then FCustomMenu  := GetString(Ptr,P.LenCustMenu);
  if P.LenDescText > 0   then FDescription := GetString(Ptr,P.LenDescText);
  if P.LenHelpText > 0   then FHelpTopic   := GetString(Ptr,P.LenHelpText);
  if P.LenStatusText > 0 then FStatusBar   := GetString(Ptr,P.LenStatusText);
  FLoadedFormFile := True;
end;

procedure TInternalName.WritePropNameName(Writer: TWriter);
var
  i: integer;
  S: string;
begin
  S := '';
  for i := 1 to Length(FName) do
    S := S + Format('%.2X',[Ord(FName[i])]);
  Writer.WriteString(S);
end;

procedure TInternalName.WritePropNameDef(Writer: TWriter);
var
  i: integer;
  S: string;
begin
  S := '';
  for i := 0 to High(FNameDef) do
    S := S + Format('%.2X',[FNameDef[i]]);
  Writer.WriteString(S);
end;

procedure TInternalName.WriteRecords(Stream: TXLSStream);
var
  Sz: integer;
begin
  if not FLoadedFormFile and (FName = '') {or (Length(FNameDef) <= 0)} then Exit;
  Sz := SizeOf(TRecNAME) - 256 +
        Length(FName) +
        Length(FNameDef) +
        Length(FCustomMenu) +
        Length(FDescription) +
        Length(FHelpTopic) +
        Length(FStatusBar);
  Stream.WriteHeader(BIFFRECID_NAME,Sz);
  Stream.WWord(FOptions);
  Stream.WByte(FKeyShortcut);
  Stream.WByte(UnicodeStringLen(FName));
  Stream.WWord(Length(FNameDef));
  Stream.WWord(FTabIndex);
  Stream.WWord(FSheetIndex);
  Stream.WByte(Length(FCustomMenu));
  Stream.WByte(Length(FDescription));
  Stream.WByte(Length(FHelpTopic));
  Stream.WByte(Length(FStatusBar));
  Stream.Write(Pointer(FName)^,Length(FName));
  if Length(FNameDef) > 0 then
    Stream.Write(FNameDef[0],Length(FNameDef));
  if FCustomMenu  <> '' then  Stream.Write(Pointer(FCustomMenu)^,Length(FCustomMenu));
  if FDescription <> '' then  Stream.Write(Pointer(FDescription)^,Length(FDescription));
  if FHelpTopic   <> '' then  Stream.Write(Pointer(FHelpTopic)^,Length(FHelpTopic));
  if FStatusBar   <> '' then  Stream.Write(Pointer(FStatusBar)^,Length(FStatusBar));
end;

function TInternalName.NameIsArea: boolean;
begin
  Result := (Length(FNameDef) = (1 + SizeOf(TPTGArea3d8))) and (FNameDef[0] = ptgArea3d);
end;

function TInternalName.NameIsCell: boolean;
begin
  Result := (Length(FNameDef) = (1 + SizeOf(TPTGRef3d8))) and (FNameDef[0] = ptgRef3d);
end;

// TODO: None of these will work with relative refs.
function TInternalName.GetCol1: integer;
begin
  if NameIsArea then
    Result := PPTGArea3d8(@FNameDef[1]).Col1
  else if NameIsCell then
    Result := PPTGRef3d8(@FNameDef[1]).Col
  else
    raise Exception.Create('Name is not of requested type.');
end;

function TInternalName.GetCol2: integer;
begin
  if NameIsArea then
    Result := PPTGArea3d8(@FNameDef[1]).Col2
  else if NameIsCell then
    Result := PPTGRef3d8(@FNameDef[1]).Col
  else
    raise Exception.Create('Name is not of requested type.');
end;

function TInternalName.GetRow1: integer;
begin
  if NameIsArea then
    Result := PPTGArea3d8(@FNameDef[1]).Row1
  else if NameIsCell then
    Result := PPTGRef3d8(@FNameDef[1]).Row
  else
    raise Exception.Create('Name is not of requested type.');
end;

function TInternalName.GetRow2: integer;
begin
  if NameIsArea then
    Result := PPTGArea3d8(@FNameDef[1]).Row2
  else if NameIsCell then
    Result := PPTGRef3d8(@FNameDef[1]).Row
  else
    raise Exception.Create('Name is not of requested type.');
end;

end.