flatexcel.pas

风格控件。。支持数据库和界面风格优化

  end;
 end;
end;

procedure TDefineExcel.EndProgress;
begin
 if Assigned(FExcelForm) then
 begin
  with FExcelForm do
  begin
    ProGauge.Progress := ProGauge.Progress+1;
    if ProGauge.Progress >= ProGauge.Max then
    begin
       Sleep(FInterval);
       Close;
    end;
  end;
  Application.ProcessMessages;
 end;
end;

procedure TDefineExcel.WriteData(Field:TField);
begin
   if Field.IsNull then
      WriteBlankCell
   else
   case FEduceType of
       dmDefault:
             case Field.DataType of
               ftSmallint,
               ftInteger,
               ftWord,
               ftAutoInc,
               ftBytes: WriteIntegerCell(Field.AsInteger);
               ftFloat,
               ftCurrency,
               ftBCD: WriteFloatCell(Field.AsFloat);
             else
               WriteStringCell(Field.AsString);
             end;
       dmString:WriteStringCell(Field.AsString);
   end;
end;
//正式写入Excel表的数据
procedure TDefineExcel.WriteDataCells;
var n: word;
    fBookMark : TBookmark;
begin
 //写入 Excel 文件开始格式
 WritePrefix;
 //写入标题名称
 WriteTitle;
 //开始写入各字段数据
 with FDataLink.DataSet do
 begin
  //禁止在数据感知控件中显示
  DisableControls;
  //初始化处理进度
  StartProgress(RecordCount);
  //记录当记录的位置
  fBookMark := GetBookmark;
  //指向第一条记录
  First;
  while not Eof do begin
   for n := 0 to ColumnCount - 1 do
   begin
    if FColumns[n].Visible then
       WriteData(FColumns[n].Field);
   end;
   EndProgress;
   Next;
  end;
  //还原处理前的记录位置
  GotoBookmark(fBookMark);
  //充许在数据感知控件中显示
  EnableControls;
 end;
 //写入 Excel 文件结束标识
 WriteSuffix;
end;

procedure TDefineExcel.SaveExcel(Save: TStream);
begin
  fCol    := 0;
  fRow    := 0;
  ExcelStream := Save;
  WriteDataCells;
end;

procedure TDefineExcel.DefineFieldMap;
var
  I: Integer;
begin
  if FColumns.State = csCustomized then
  begin
    FDataLink.SparseMap := True;
    for I := 0 to FColumns.Count-1 do
      FDataLink.AddMapping(FColumns[I].FieldName);
  end
  else
  begin
    FDataLink.SparseMap := False;
    with FDataLink.Dataset do
      for I := 0 to FieldList.Count - 1 do
        with FieldList[I] do if Visible then FDataLink.AddMapping(FullName);
  end;
end;

procedure TDefineExcel.InitColumns;

  function FieldIsMapped(F: TField): Boolean;
  var
    X: Integer;
  begin
    Result := False;
    if F = nil then Exit;
    for X := 0 to FDataLink.FieldCount-1 do
      if FDataLink.Fields[X] = F then
      begin
        Result := True;
        Exit;
      end;
  end;

  procedure CheckForPassthroughs;  // check for Columns.State flip-flop
  var
    SeenPassthrough: Boolean;
    I, J: Integer;
    Column: TEduceData;
  begin
    SeenPassthrough := False;
    for I := 0 to FColumns.Count-1 do
      if not FColumns[I].IsStored then
        SeenPassthrough := True
      else if SeenPassthrough then
      begin
        for J := FColumns.Count-1 downto 0 do
        begin
          Column := FColumns[J];
          if not Column.IsStored then
            Column.Free;
        end;
        Exit;
      end;
  end;

  procedure ResetColumnFieldBindings;
  var
    I, J, K: Integer;
    Fld: TField;
    Column: TEduceData;
  begin
    if FColumns.State = csDefault then
    begin
      if (not FDataLink.Active) and (FDataLink.DefaultFields) then
          FColumns.Clear
      else
      begin
        for J := FColumns.Count-1 downto 0 do
        begin
          with FColumns[J] do
          begin
           if not Assigned(Field) or not FieldIsMapped(Field) then
              Free;
          end;
        end;
      end;
      I := FDataLink.FieldCount;
      //if (I = 0) and (FColumns.Count = 0) then
      //    Inc(I);
      for J := 0 to I-1 do
      begin
        Fld := FDataLink.Fields[J];
        if Assigned(Fld) then
        begin
          K := J;
          while (K < FColumns.Count) and (FColumns[K].Field <> Fld) do
            Inc(K);
          if K < FColumns.Count then
             Column := FColumns[K]
          else
          begin
             Column := FColumns.InternalAdd;
             Column.Field := Fld;
          end;
        end
        else
          Column := FColumns.InternalAdd;
        Column.Index := J;
      end;
    end
    else
    begin
      for I := 0 to FColumns.Count-1 do
          FColumns[I].Field := nil;
    end;
  end;
begin
  if ([csLoading, csDestroying] * ComponentState) <> [] then
     Exit;
  CheckForPassthroughs;
  FDatalink.ClearMapping;
  if FDatalink.Active then
     DefineFieldMap;
  ResetColumnFieldBindings;
end;

procedure TDefineExcel.SeTEduceType(const Value: TEduceType);
begin
 if FEduceType <> Value then
    FEduceType := Value;
end;

procedure TDefineExcel.SetColumns(const Value: TEduceDatas);
begin
  FColumns.Assign(Value);
end;

procedure TDefineExcel.DefineProperties(Filer: TFiler);
var
  StoreIt: Boolean;
  vState: TEduceDatasState;
begin
  vState := EduceDatas.State;
  if Filer.Ancestor = nil then
    StoreIt := vState = csCustomized
  else
    if vState <> TDefineExcel(Filer.Ancestor).EduceDatas.State then
      StoreIt := True
    else
      StoreIt := (vState = csCustomized) and
        (not CollectionsEqual(EduceDatas, TDefineExcel(Filer.Ancestor).EduceDatas, Self, TDefineExcel(Filer.Ancestor)));

  Filer.DefineProperty('Columns', ReadColumns, WriteColumns, StoreIt);
  inherited DefineProperties(Filer);
end;

procedure TDefineExcel.ReadColumns(Reader: TReader);
begin
  EduceDatas.Clear;
  Reader.ReadValue;
  Reader.ReadCollection(EduceDatas);
end;

procedure TDefineExcel.WriteColumns(Writer: TWriter);
begin
  if EduceDatas.State = csCustomized then
     Writer.WriteCollection(EduceDatas)
  else  // ancestor state is customized, ours is not
     Writer.WriteCollection(nil);
end;

function TDefineExcel.GetFieldCount: Integer;
begin
  if Assigned(FDataLink.DataSet) then
     result := FDataLink.FieldCount
  else
     result := 0;
end;

procedure TDefineExcel.BeginLayout;
begin
  BeginUpdate;
  if FLayoutLock = 0 then
     EduceDatas.BeginUpdate;
  Inc(FLayoutLock);
end;

procedure TDefineExcel.BeginUpdate;
begin
  Inc(FUpdateLock);
end;

procedure TDefineExcel.EndLayout;
begin
  if FLayoutLock > 0 then
  begin
    try
      try
        if FLayoutLock = 1 then
           InitColumns;
      finally
        if FLayoutLock = 1 then
           FColumns.EndUpdate;
      end;
    finally
      Dec(FLayoutLock);
      EndUpdate;
    end;
  end;
end;

procedure TDefineExcel.EndUpdate;
begin
  if FUpdateLock > 0 then
     Dec(FUpdateLock);
end;

procedure TDefineExcel.LayoutChanged;
begin
  if AcquireLayoutLock then
     EndLayout;
end;

function TDefineExcel.AcquireLayoutLock: Boolean;
begin
  Result := (FUpdateLock = 0) and (FLayoutLock = 0);
  if Result then BeginLayout;
end;

procedure TDefineExcel.Loaded;
begin
  inherited Loaded;
  LayoutChanged;
end;

function TDefineExcel.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TDefineExcel.SetDataSource(const Value: TDataSource);
begin
  if Value = FDatalink.Datasource then Exit;
  if Assigned(Value) then
    if Assigned(Value.DataSet) then
      if Value.DataSet.IsUnidirectional then
         DatabaseError(SDataSetUnidirectional);
  FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

procedure TDefineExcel.LinkActive(Value: Boolean);
begin
  try
    LayoutChanged;
  finally
    //
  end;
end;

function TDefineExcel.CreateDataLink: TEduceLink;
begin
  Result := TEduceLink.Create(Self);
end;

function TDefineExcel.GetColumnCount: integer;
begin
  Result := FColumns.Count;
end;

function TDefineExcel.GetEduceCount: integer;
var
  i:integer;
begin
  result := 0;
  for i:= 0 to FColumns.Count - 1 do
      if FColumns[i].Visible then result := result + 1;
end;

procedure TDefineExcel.ExportAll;
var i:integer;
begin
  for i:=0 to ColumnCount - 1 do FColumns[i].Visible := True;
end;

function TDefineExcel.GetFields(FieldIndex: Integer): TField;
begin
  Result := FDatalink.Fields[FieldIndex];
end;

procedure TDefineExcel.CancelLayout;
begin
  if FLayoutLock > 0 then
  begin
    if FLayoutLock = 1 then
       EduceDatas.EndUpdate;
    Dec(FLayoutLock);
    EndUpdate;
  end;
end;

procedure TDefineExcel.ExecuteSave;
var
  SaveDlg: TSaveDialog;
  FileStream: TFileStream;
  inx: integer;
  UseState: boolean;
begin
 FieldForm := TFieldForm.Create(self);
 try
  FieldForm.FieldBox.Items.Clear;
  for inx := 0 to FColumns.Count - 1 do
  begin
      FieldForm.FieldBox.Items.Add(FColumns[inx].Caption);
      FieldForm.FieldBox.Checked[inx] := FColumns[inx].Visible;
  end;
  FieldForm.ShowModal;
  if FieldForm.ModalResult = mrOk then
  begin
   for inx := 0 to FieldForm.FieldBox.Items.Count - 1 do
       FColumns[inx].Visible := FieldForm.FieldBox.Checked[inx];
   SaveDlg := TSaveDialog.Create(self);
   try
    SaveDlg.DefaultExt := '.XLS';
    SaveDlg.Filter     := '微软电子表格(MS-EXCEL文件)|*.XLS';
    SaveDlg.Title      := '保存为';
    if SaveDlg.Execute then
    begin
     if Assigned(FDataLink.DataSet) then
     begin
      useState := true;
      if FileExists(SaveDlg.FileName) then
         useState := DeleteFile(SaveDlg.FileName);
      if useState then
      begin
       FileStream := TFileStream.Create(SaveDlg.FileName, fmCreate);
       try
        SaveExcel(FileStream);
       Finally
        FileStream.Free;
       end;
      end
      else ShowMessage('文件正在使用中,不能覆盖文件!');
     end;
    end;
   finally
    SaveDlg.Free;
   end;
  end;
 finally
  FieldForm.Free;
  FieldForm := Nil;
 end;
end;

procedure TDefineExcel.InitFields;
var
  inx: integer;
  Col: TEduceData;
begin
 if Assigned(FDataLink.DataSet) then
 begin
 with FDataLink.DataSet.FieldDefs do
 begin
  if (not FDataLink.Active) and (Count > 0) then
  begin
    FColumns.BeginUpdate;
    FColumns.Clear;
    for inx:=0 to Count - 1 do
    begin
      Col := FColumns.Add;
      Col.FieldName := Items[inx].Name;
      Col.Caption   := Items[inx].Name;
    end;
    FColumns.EndUpdate;
  end;
 end;
 end;
end;

procedure TDefineExcel.ClearFields;
begin
 FColumns.BeginUpdate;
 FColumns.Clear;
 FColumns.EndUpdate;
end;

procedure TDefineExcel.RestoreFields;
var
 inx : integer;
 col : TEduceData;
begin
 FColumns.BeginUpdate;
 for inx:=0 to FColumns.Count - 1 do
 begin
   Col := FColumns[inx];
   Col.Caption  := Col.FieldName;
   Col.Visible  := True;
 end;
 FColumns.EndUpdate;
end;

{ TEduceLink }

const
  MaxMapSize = (MaxInt div 2) div SizeOf(Integer);

type
  TIntArray = array[0..MaxMapSize] of Integer;
  PIntArray = ^TIntArray;

constructor TEduceLink.Create(ADSExcel: TDefineExcel);
begin
  inherited Create;
  FCells        := ADSExcel;
  VisualControl := True;
end;

destructor TEduceLink.Destroy;
begin
  ClearMapping;
  inherited Destroy;
end;

function TEduceLink.GetDefaultFields: Boolean;
var
  I: Integer;
begin
  Result := True;
  if DataSet <> nil then
     Result := DataSet.DefaultFields;
  if Result and SparseMap then
  for I := 0 to FFieldCount-1 do
    if FFieldMap[I] < 0 then
    begin
      Result := False;
      Exit;
    end;
end;

function TEduceLink.GetFields(I: Integer): TField;
begin
  if (0 <= I) and (I < FFieldCount) and (FFieldMap[I] >= 0) then
    Result := DataSet.FieldList[FFieldMap[I]]
  else
    Result := nil;
end;

function TEduceLink.AddMapping(const FieldName: string): Boolean;
var
  Field: TField;
  NewSize: Integer;
begin
  Result := True;
  if FFieldCount >= MaxMapSize then
     RaiseGridError(STooManyColumns);
  if SparseMap then
     Field := DataSet.FindField(FieldName)
  else
     Field := DataSet.FieldByName(FieldName);

  if FFieldCount = Length(FFieldMap) then
  begin
    NewSize := Length(FFieldMap);
    if NewSize = 0 then
       NewSize := 8
    else
       Inc(NewSize, NewSize);
    if (NewSize < FFieldCount) then
        NewSize := FFieldCount + 1;
    if (NewSize > MaxMapSize) then
        NewSize := MaxMapSize;
    SetLength(FFieldMap, NewSize);
  end;
  if Assigned(Field) then
  begin
    FFieldMap[FFieldCount] := Dataset.FieldList.IndexOfObject(Field);
    Field.FreeNotification(FCells);
  end
  else
    FFieldMap[FFieldCount] := -1;
  Inc(FFieldCount);
end;

procedure TEduceLink.ActiveChanged;
begin
  if Active and Assigned(DataSource) then
    if Assigned(DataSource.DataSet) then
      if DataSource.DataSet.IsUnidirectional then
         DatabaseError(SDataSetUnidirectional);
  FCells.LinkActive(Active);
  FModified := False;
end;

procedure TEduceLink.ClearMapping;
begin
  FFieldMap   := nil;
  FFieldCount := 0;
end;

procedure TEduceLink.LayoutChanged;
var
  SaveState: Boolean;
begin
  SaveState := FCells.LayoutSet;
  FCells.LayoutSet := True;
  try
    FCells.LayoutChanged;
  finally
    FCells.LayoutSet := SaveState;
  end;
  inherited LayoutChanged;
end;

function TEduceLink.GetMappedIndex(ColIndex: Integer): Integer;
begin
  if (0 <= ColIndex) and (ColIndex < FFieldCount) then
    Result := FFieldMap[ColIndex]
  else
    Result := -1;
end;

function TEduceLink.IsAggRow(Value: Integer): Boolean;
begin
  Result := False;
end;

end.