qexport4common.pas

Advanced.Export.Component.v4.01.rar,delphi 第三方控件

var
  x, y, l: integer;
begin
  with Canvas do begin
    Pen.Style := psSolid;
    case Style of
      bstMedium,
      bstMediumDashed,
      bstMediumDashDot,
      bstSlantedDashDot,
      bstMediumDashDotDot: Pen.Width := 2;
      bstThick: Pen.Width := 3;
      else Pen.Width := 1;
    end;

    l := (Rect.Right - Rect.Left) - 10;
    y := (Rect.Bottom + Rect.Top) div 2;
    x := 10;
    case Style of
      bstNone: TextOut((Rect.Right + Rect.Left - TextWidth({$IFDEF WIN32}QExportLoadStr(QED_XLS_Border_None){$ENDIF}
                                                           {$IFDEF LINUX}QED_XLS_Border_None{$ENDIF})) div 2,
                       (Rect.Bottom + Rect.Top - TextHeight({$IFDEF WIN32}QExportLoadStr(QED_XLS_Border_None){$ENDIF}
                                                            {$IFDEF LINUX}QED_XLS_Border_None{$ENDIF})) div 2,
                                                            {$IFDEF WIN32}QExportLoadStr(QED_XLS_Border_None){$ENDIF}
                                                            {$IFDEF LINUX}QED_XLS_Border_None{$ENDIF});

      bstThin,
      bstMedium,
      bstThick: DrawLine(Canvas, x, y, x + l, y, l);

      bstDashed,
      bstMediumDashed: while DrawLine(Canvas, x, y, x + 7, y, l) = 0  do Inc(x, 14);

      bstDotted: while DrawLine(Canvas, x, y, x + 3, y, l) = 0  do Inc(x, 6);

      bstDouble: begin
        DrawLine(Canvas, x, y - 1, x + l, y - 1, l);
        DrawLine(Canvas, x, y + 1, x + l, y + 1, l);
      end;

      bstHair: while DrawLine(Canvas, x, y, x + 2, y, l) = 0  do Inc(x, 4);

      bstDashDot,
      bstMediumDashDot,
      bstSlantedDashDot:
        while (DrawLine(Canvas, x, y, x + 7, y, l) = 0) do begin
          if DrawLine(Canvas, x + 11, y, x + 14, y, l) <> 0 then Break;
          Inc(x, 18);
        end;

      bstDashDotDot,
      bstMediumDashDotDot:
        while DrawLine(Canvas, x, y, x + 7, y, l) = 0 do begin
          if DrawLine(Canvas, x + 11, y, x + 14, y, l) <> 0 then Break;
          if DrawLine(Canvas, x + 18, y, x + 21, y, l) <> 0 then Break;
          Inc(x, 25);
        end
    end;
  end;
end;

procedure DrawPattern(Canvas: TCanvas; Index, X, Y: integer);
begin
  with Canvas do
    case Index of
      $02: begin
        MoveTo(X, Y);
        LineTo(X + 1, Y);
        MoveTo(X + 2, Y);
        LineTo(X + 3, Y);

        MoveTo(X + 1, Y + 1);
        LineTo(X + 2, Y + 1);
        MoveTo(X + 3, Y + 1);
        LineTo(X + 4, Y + 1);

        MoveTo(X, Y + 2);
        LineTo(X + 1, Y + 2);
        MoveTo(X + 2, Y + 2);
        LineTo(X + 3, Y + 2);

        MoveTo(X + 1, Y + 3);
        LineTo(X + 2, Y + 3);
        MoveTo(X + 3, Y + 3);
        LineTo(X + 4, Y + 3);
      end;
      $03: begin
        MoveTo(X + 1, Y);
        LineTo(X + 4, Y);

        MoveTo(X, Y + 1);
        LineTo(X + 2, Y + 1);
        MoveTo(X + 3, Y + 1);
        LineTo(X + 4, Y + 1);

        MoveTo(X + 1, Y + 2);
        LineTo(X + 4, Y + 2);

        MoveTo(X, Y + 3);
        LineTo(X + 2, Y + 3);
        MoveTo(X + 3, Y + 3);
        LineTo(X + 4, Y + 3);
      end;
      $04: begin
        MoveTo(X, Y);
        LineTo(X + 1, Y);

        MoveTo(X + 2, Y + 1);
        LineTo(X + 3, Y + 1);

        MoveTo(X, Y + 2);
        LineTo(X + 1, Y + 2);

        MoveTo(X + 2, Y + 3);
        LineTo(X + 3, Y + 3);
      end;
      $05: begin
        MoveTo(X, Y);
        LineTo(X + 4, Y);

        MoveTo(X, Y + 1);
        LineTo(X + 4, Y + 1);
      end;
      $06: begin
        MoveTo(X, Y);
        LineTo(X, Y + 4);

        MoveTo(X + 1, Y);
        LineTo(X + 1, Y + 4);
      end;
      $07: begin
        MoveTo(X + 1, Y);
        LineTo(X + 5, Y + 4);

        MoveTo(X, Y);
        LineTo(X + 4, Y + 4);
      end;
      $08: begin
        MoveTo(X + 3, Y);
        LineTo(X - 1, Y + 4);

        MoveTo(X + 4, Y);
        LineTo(X, Y + 4);
      end;
      $09: begin
        MoveTo(X, Y);
        LineTo(X + 2, Y);

        MoveTo(X, Y + 1);
        LineTo(X + 2, Y + 1);

        MoveTo(X + 2, Y + 2);
        LineTo(X + 4, Y + 2);

        MoveTo(X + 2, Y + 3);
        LineTo(X + 4, Y + 3);
      end;
      $0A: begin
        MoveTo(X, Y);
        LineTo(X + 4, Y);

        MoveTo(X, Y + 1);
        LineTo(X + 2, Y + 1);

        MoveTo(X + 2, Y + 2);
        LineTo(X + 4, Y + 2);

        MoveTo(X, Y + 3);
        LineTo(X + 4, Y + 3);
      end;
      $0B: begin
        MoveTo(X, Y);
        LineTo(X + 4, Y);
      end;
      $0C: begin
        MoveTo(X, Y);
        LineTo(X, Y + 4);
      end;
      $0D: begin
        MoveTo(X, Y);
        LineTo(X + 4, Y + 4);
      end;
      $0E: begin
        MoveTo(X + 4, Y);
        LineTo(X, Y + 4);
      end;
      $0F: begin
        MoveTo(X, Y);
        LineTo(X + 4, Y);

        MoveTo(X, Y);
        LineTo(X, Y + 4);
      end;
      $10: begin
        MoveTo(X, Y);
        LineTo(X + 4, Y + 4);

        MoveTo(X + 2, Y);
        LineTo(X, Y + 2);
      end;
      $11: begin
        MoveTo(X, Y);
        LineTo(X + 1, Y);

        MoveTo(X + 2, Y + 2);
        LineTo(X + 3, Y + 2);
      end;
      $12: begin
        MoveTo(X, Y);
        LineTo(X + 1, Y);

        MoveTo(X + 4, Y + 2);
        LineTo(X + 5, Y + 2);
      end;
    end;
end;

procedure IncLeftAndTop(Control: TControl);
begin
  Control.Left := Control.Left + 1;
  Control.Top := Control.Top + 1;
end;

procedure DecLeftAndTop(Control: TControl);
begin
  Control.Left := Control.Left - 1;
  Control.Top := Control.Top - 1;
end;

procedure PaintSampleFont(AFont: TFont; APaintBox: TPaintBox;
  PaintColor: boolean);
const
  SampleText = 'AaBbCc XxYyZz';
var
  TextLength: integer;
begin
  with APaintBox.Canvas do begin
    Pen.Color := clBlack;
    Brush.Color := clWhite;
    Brush.Style := bsSolid;
    Rectangle(0, 0, APaintBox.Width, APaintBox.Height);
    Font.Assign(AFont);
    if not PaintColor then
      Font.Color := clBlack;
    TextLength := TextWidth(SampleText);
    TextOut((APaintBox.Width - TextLength) div 2,
      (APaintBox.Height - TextHeight(SampleText)) div 2, SampleText);
  end;
end;

procedure SelectFontForPaintBox(FontDialog: TFontDialog; AFont: TFont;
  APaintBox: TPaintBox);
begin
  FontDialog.Font.Assign(AFont);
  if FontDialog.Execute then begin
    AFont.Assign(FontDialog.Font);
    APaintBox.Repaint;
  end;
end;

procedure SetListItemIndex(Item: TListItem; Index: integer);

  procedure ChangeTwoItems(Src, Dst: TListItem);
  begin
    Dst.Caption:= Src.Caption;
    Dst.ImageIndex := Src.ImageIndex;
    Dst.Data := Src.Data;
  end;

var
  ListView: TListView;

  FItemCaption: string;
  FItemImageIndex: integer;
  FItemData: Pointer;

  idx, i: integer;
begin
  if Index < 0 then Exit;
  if not Assigned(Item) then Exit;
  idx := Item.Index;
  if idx = Index then Exit;
  ListView := Item.ListView as TListView;
  if not Assigned(ListView.Items[Index]) then Exit;

  FItemCaption := Item.Caption;
  FItemImageIndex := Item.ImageIndex;
  FItemData := Item.Data;

  if idx > Index then
    for i := idx downto Index + 1 do
      ChangeTwoItems(ListView.Items[i - 1], ListView.Items[i]);

  if idx < Index then
    for i := idx to Index - 1 do
      ChangeTwoItems(ListView.Items[i + 1], ListView.Items[i]);

  ListView.Items[Index].Caption:= FItemCaption;
  ListView.Items[Index].ImageIndex := FItemImageIndex;
  ListView.Items[Index].Data := FItemData;
end;

function MoveListItem(Item: TListItem; Dst: TListView; Move: boolean;
  Index: integer): TListItem;
var
  Idx: integer;
  Src: TListView;
begin
  Result := nil;
  if not Assigned(Item) or not Assigned(Dst) then Exit;
  Src := Item.ListView as TListView;
  {$IFDEF WIN32}
  if Index < 0
    then Result := Dst.Items.Add
    else Result := Dst.Items.Insert(Index);
  {$ENDIF}
  {$IFDEF LINUX}
    Result := Dst.Items.Add;
  {$ENDIF}
  Result.Caption := Item.Caption;
  Result.Data := Item.Data;
  Idx := Item.Index;
  if Move then Item.Delete;

  if Src.Items.Count > 0 then begin
    if Idx >= Src.Items.Count
      then Src.Items[Src.Items.Count - 1].Selected := true
      else if Idx < 0
           then Src.Items[0].Selected := true
           else Src.Items[Idx].Selected := true;
  end;
end;
{$ENDIF}

function CalcStringType(const S,
  BooleanTrue, BooleanFalse: QEString): TQExportColType;
var
  Year, Month, Day: Word;
  Hour, Min, Sec, MSec: Word;
begin
  Result := ectString;
  if S = EmptyStr then Exit;

  //-- IsBoolean
  if (QECompareText(S, BooleanTrue) = 0) or
     (QECompareText(S, BooleanFalse) = 0)  then begin
    Result := ectBoolean;
    Exit;
  end;
  //-- IsInteger
  try StrToInt(S); Result := ectInteger; Exit;
  except end;
  //-- IsFloat
  try StrToFloat(S); Result := ectFloat; Exit;
  except end;
  //-- IsDateTime
  try
    StrToDateTime(S);
    Result := ectDateTime;
    DecodeTime(StrToDateTime(S), Hour, Min, Sec, MSec);
    if (Hour = 0) and (Min = 0) and (Sec = 0) and (MSec = 0) then begin
      Result := ectDate;
      Exit;
    end
    else begin
      DecodeDate(StrToDateTime(S), Year, Month, Day);
      if (Year = 1899) and (Month = 12) and (Day = 30) then begin
        Result := ectTime;
        Exit;
      end;
    end;
  except
  end;
end;

{$IFNDEF NOGUI}
procedure DrawXLSCell(PaintBox: TPaintBox; Format: TxlsFormat);

  procedure OutText;
  const
    TXT = 'Aa Zz';
  var
    X, Y: integer;
    {$IFDEF WIN32}
    USz, UPz, XX: integer;
    otm: TOutlineTextmetric;
    {$ENDIF}
  begin
    with PaintBox.Canvas.Font do begin
      Name := Format.Font.Name;
      Size := Format.Font.Size;
      Charset := Format.Font.Charset;