cxexport.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,045 行 · 第 1/3 页

begin
  Result := '';
end;

procedure TcxCustomExportProvider.Clear;
begin
end;

{ TcxExportStyleManager }
constructor TcxExportStyleManager.Create;
begin
  raise EcxExportData.Create(cxGetResString(@scxStyleManagerCreate));
end;

destructor TcxExportStyleManager.Destroy;
begin
  if FRefCount <> 0 then
    raise EcxExportData.Create(cxGetResString(@scxStyleManagerKill));
  inherited Destroy;
end;

procedure TcxExportStyleManager.Clear;
var
  I: Integer;
begin
  Dec(FRefCount);
  if FRefCount = 0 then
  begin
    try
      for I := 0 to FStyles.Count - 1 do
        FreeMem(PcxCacheCellStyle(FStyles[I]));
      if StylesCache.Find(FFileName, I) then
        StylesCache.Delete(I);
    finally
      FStyles.Free;
      Destroy;
    end;
  end;
end;

class function TcxExportStyleManager.GetInstance(
  const AFileName: string): TcxExportStyleManager;
var
  AIndex: Integer;
begin
  if StylesCache.Find(AFileName, AIndex) then
  begin
    Result := TcxExportStyleManager(StylesCache.Objects[AIndex]);
    Result.RegisterStyle(DefaultCellStyle);
    Inc(Result.FRefCount);
  end
  else
    Result := CreateInstance(AFileName);
end;

function TcxExportStyleManager.GetStyle(const AIndex: Integer): PcxCacheCellStyle;
begin
  Result := FStyles[AIndex];
end;

function TcxExportStyleManager.RegisterStyle(
  const AStyle: TcxCacheCellStyle): Integer;
var
  I: Integer;
  NewStyleItem, AStylePtr: PcxCacheCellStyle;
begin
  AStylePtr := @AStyle;
  AStylePtr^.HashCode :=
    cxExport.GetHashCode(AStyle, SizeOf(TcxCacheCellStyle) - SizeOf(Integer));
  for I := 0 to FStyles.Count - 1 do
    if StyleCompare(FStyles[I], @AStyle) then
    begin
      Result := I;
      Exit;
    end;
  New(NewStyleItem);
  NewStyleItem^ := AStylePtr^;
  Result := FStyles.Add(NewStyleItem);
end;

function TcxExportStyleManager.GetCount: Integer;
begin
  Result := FStyles.Count;
end;

function TcxExportStyleManager.GetItem(AIndex: Integer): TcxCacheCellStyle;
begin
  Result := GetStyle(AIndex)^;
end;

constructor TcxExportStyleManager.CreateInstance(const AFileName: string);
begin
  FStyles := TList.Create;
  StylesCache.AddObject(AFileName, Self);
  FFileName := AFileName;
  FRefCount := 1;
end;

function TcxExportStyleManager.StyleCompare(
  const AStyle1, AStyle2: PcxCacheCellStyle): Boolean;
begin
  Result := (AStyle1.HashCode = AStyle2.HashCode) and
    CompareMem(AStyle1, AStyle2, SizeOf(TcxCacheCellStyle) - SizeOf(Integer));
end;

constructor TFileStreamEx.Create(const FileName: string; Mode: Word);
{$IFDEF DELPHI6}
var
  AName: WideString;
{$ENDIF}
begin
{$IFDEF DELPHI6}
  if cxUnicodeSupported then
  begin
    AName := cxStrToUnicode(FileName);
    FHandle := Integer(CreateFileW(PWideChar(AName), GENERIC_READ or GENERIC_WRITE,
      0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0));
  end
  else
{$ENDIF}
    inherited Create(FileName, Mode);
end;

function CompareValues(AItem1, AItem2: Pointer): Integer;
begin
  Result := Integer(AItem1) - Integer(AItem2);
end;

{ TcxExportIntList }

procedure TcxExportIntList.Add(AValue: Integer);
begin
  if Capacity - Count < 2 then
    if Count * 2 < 1024 then
      Capacity := 1024
    else
      Capacity := Count  * 2;
  inherited Add(Pointer(AValue));
end;

procedure TcxExportIntList.AddPairs(AValue1, AValue2: Integer);
begin
  if Capacity - Count < 2 then
    if Count * 2 < 1024 then
      Capacity := 1024
    else
      Capacity := Count  * 2;
  inherited Add(Pointer(AValue1));
  inherited Add(Pointer(AValue2));
end;

function TcxExportIntList.Last: Integer;
begin
  Result := Integer(inherited Last);
end;

function TcxExportIntList.First: Integer;
begin
  Result := Integer(inherited First);
end;

function TcxExportIntList.GetItem(AIndex: Integer): Integer;
begin
  Result := Integer(List^[AIndex]);
end;

procedure TcxExportIntList.SetItem(AIndex, AValue: Integer);
begin
  Integer(List^[AIndex]) := AValue
end;

{ TcxExportScale }

procedure TcxExportScale.Arrange;
var
  AIndex, I: Integer;
begin
  Sort(@CompareValues);
  AIndex := 0;
  for I := 1 to Count - 1 do
  begin
    if List^[AIndex] <> List^[I] then
      Inc(AIndex);
    List^[AIndex] := List^[I];
  end;
  if Count > 0 then
    Count := AIndex + 1;
end;

function TcxExportScale.IndexOf(AItem: Integer): Integer;
begin
  Result := IndexOfEx(AItem, 0, VisibleCount);
end;

function TcxExportScale.IndexOfEx(AValue, AFirstIndex, ALastIndex: Integer): Integer;
var
  L, H, I, C: Integer;
begin
  Result := -1;
  // binary search
  L := AFirstIndex;
  H := ALastIndex;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := Integer(List^[I]) - AValue;
    if C < 0 then
      L := I + 1
    else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := I;
        Break;
      end;
    end;
  end;
  if Result = - 1 then
    Error(@cxExportListIndexError, AValue);
end;

procedure TcxExportScale.GetPosition(
  AValue1, AValue2: Integer; out AIndex1, AIndex2: Integer);
begin
  AIndex1 := IndexOf(AValue1);
  AIndex2 := IndexOfEx(AValue2, AIndex1, Count - 1);
end;

procedure TcxExportScale.GetPositionEx(AValue1, AValue2,
  AFirstIndex, ALastIndex: Integer; out AIndex1, AIndex2: Integer);
begin
  AIndex1 := IndexOfEx(AValue1, AFirstIndex, ALastIndex);
  AIndex2 := IndexOfEx(AValue2, AIndex1, ALastIndex);
end;

function TcxExportScale.GetVisibleCount: Integer;
begin
  Result := Count;
  Dec(Result);
end;

function TcxExportScale.GetDelta(AIndex: Integer): Integer;
begin
  Result := Integer(List^[AIndex + 1]) - Integer(List^[AIndex]);
end;

function GetCurrencyFormat: string;

  function GetCharString(C: Char; ACount: Integer): string;
  var
    I: Integer;
  begin
    Result := '';
    for I := 1 to ACount do
      Result := Result + C;
  end;

  function GetPositiveCurrencyFormat(const AFormat, ACurrStr: string): string;
  begin
    if Length(ACurrStr) > 0 then
      case Sysutils.CurrencyFormat of
        0: Result := ACurrStr + AFormat; { '$1' }
        1: Result := AFormat + ACurrStr; { '1$' }
        2: Result := ACurrStr + ' ' + AFormat; { '$ 1' }
        3: Result := AFormat + ' ' + ACurrStr; { '1 $' }
      end;
  end;

  function GetNegativeCurrencyFormat(const AFormat, ACurrStr: string): string;
  begin
    case Sysutils.NegCurrFormat of
      0: Result := '(' + ACurrStr + AFormat + ')';
      1: Result := '-' + ACurrStr + AFormat;
      2: Result := ACurrStr + '-' + AFormat;
      3: Result := ACurrStr + AFormat + '-';
      4: Result := '(' + AFormat + ACurrStr + ')';
      5: Result := '-' + AFormat + ACurrStr;
      6: Result := AFormat + '-' + ACurrStr;
      7: Result := AFormat + ACurrStr + '-';
      8: Result := '-' + AFormat + ' ' + ACurrStr;
      9: Result := '-' + ACurrStr + ' ' + AFormat;
      10: Result := AFormat + ' ' + ACurrStr + '-';
      11: Result := ACurrStr + ' ' + AFormat + '-';
      12: Result := ACurrStr + ' ' + '-' + AFormat;
      13: Result := AFormat + '-' + ' ' + ACurrStr;
      14: Result := '(' + ACurrStr + ' ' + AFormat + ')';
      15: Result := '(' + AFormat + ' ' + ACurrStr + ')';
    end;
  end;

var
  ACurrStr: string;
  I: Integer;
  C: Char;
begin
  if CurrencyDecimals > 0 then
    Result := GetCharString('0', CurrencyDecimals)
  else
    Result := '';
  Result := ',0.' + Result;
  ACurrStr := '';
  for I := 1 to Length(CurrencyString) do
  begin
    C := CurrencyString[I];
    if (C = ',') or (C = '.') then
      ACurrStr := ACurrStr + '''' + C + ''''
    else
      ACurrStr := ACurrStr + C;
  end;
  Result := GetPositiveCurrencyFormat(Result, ACurrStr) + ';' +
    GetNegativeCurrencyFormat(Result, ACurrStr);
end;

procedure cxExportInit(AGetResString: TcxGetResourceStringProc;
  AColorProc: Pointer; AIsNativeColor: Boolean);
begin
  cxGetResString := AGetResString;
  cxGetRgbColor := AColorProc;
  IsNativeColor := AIsNativeColor;
  cxUnicodeSupported := (Win32Platform = VER_PLATFORM_WIN32_NT) and
    (Win32MajorVersion >= 5);
{$IFDEF WIN32}
  cxWindowColor := Windows.GetSysColor(COLOR_WINDOW);
  cxBtnTextColor := Windows.GetSysColor(COLOR_BTNTEXT);
  cxBtnFaceColor := Windows.GetSysColor(COLOR_BTNFACE);
  cxBtnShadowColor := Windows.GetSysColor(COLOR_BTNSHADOW);
{$ELSE}
  cxWindowColor := cxColorToRGB(clWindow);
  cxBtnTextColor := cxColorToRGB(clBtnText);
  cxBtnFaceColor := cxColorToRGB(clBtnFace);
  cxBtnShadowColor := ColorToRGB(clBtnShadow);
{$ENDIF}
  FreeAndNil(StylesCache);
  StylesCache := TStringList.Create;
  DefaultCellStyle := CreateDefaultCellStyle;
  cxExportCurrencyFormat := GetCurrencyFormat;
end;

initialization
  StylesCache := nil;

finalization
  FreeAndNil(StylesCache);

end.