jvdbgridexport.pas

East make Tray Icon in delphi

    else
      FWord.ActiveDocument.PageSetup.Orientation := 1;
    lTable := FWord.ActiveDocument.Tables.Add(FWord.ActiveDocument.Range, lRowCount + 1, lColVisible);
    FWord.ActiveDocument.Range.InsertAfter('Date ' + DateTimeToStr(Now));
    // (rom) This is correct Delphi. See "positional parameters" in the Delphi help.
    lTable.AutoFormat(Format := WordFormat); // FormatNum, 1, 1, 1, 1, 1, 0, 0, 0, 1

    K := 1;
    for I := 0 to FColumnCount - 1 do
      if FRecordColumns[I].Visible then
      begin
        lTable.Cell(1, K).Range.InsertAfter(FRecordColumns[I].ColumnName);
        Inc(K);
      end;

    J := 2;
    with Grid.DataSource.DataSet do
    begin
      lRecCount := RecordCount;
      ARecNo := 0;
      DoProgress(0, lRecCount, ARecNo, Caption);
      DisableControls;
      lBookmark := GetBookmark;
      First;
      try
        while not Eof do
        begin
          K := 1;
          for I := 0 to FColumnCount - 1 do
          begin
            if FRecordColumns[I].Exportable and not FRecordColumns[I].Field.IsNull then
            try
              lTable.Cell(J, K).Range.InsertAfter(string(FRecordColumns[I].Field.Value));
            except
              Result := False;
              HandleException;
              // Remember problem but continue
            end;
            if FRecordColumns[I].Visible then
              Inc(K);
          end;
          Next;
          Inc(J);
          Inc(ARecNo);
          if not DoProgress(0, lRecCount, ARecNo, Caption) then
            Last;
        end;
        DoProgress(0, lRecCount, lRecCount, Caption);
      finally
        try
          if BookmarkValid(lBookmark) then
            GotoBookmark(lBookmark);
        except
          HandleException;
        end;
        if lBookmark <> nil then
          FreeBookmark(lBookmark);
        EnableControls;
      end;
    end;
    lTable.UpdateAutoFormat;
  except
    HandleException;
  end;
end;

procedure TJvDBGridWordExport.DoSave;
var
  lName: OleVariant;
begin
  inherited DoSave;
  if VarIsEmpty(FWord) then
    Exit;
  try
    lName := OleVariant(FileName);
    FWord.ActiveDocument.SaveAs(lName);
  except
    HandleException;
  end;
end;

procedure TJvDBGridWordExport.DoClose;
begin
  if not VarIsEmpty(FWord) and (FClose <> scNever) then
  try
    if (FClose = scAlways) or not FRunningInstance then
    begin
      FWord.ActiveDocument.Close(wdDoNotSaveChanges, EmptyParam, EmptyParam);
      FWord.Quit;
    end;
    FWord := Unassigned;
  except
    HandleException;
  end;
end;

//=== { TJvDBGridExcelExport } ===============================================

constructor TJvDBGridExcelExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Caption := RsExportExcel;
  FExcel := Unassigned;
  FVisible := False;
  FOrientation := woPortrait;
  FClose := scNewInstance;
end;

destructor TJvDBGridExcelExport.Destroy;
begin
  DoClose;
  inherited Destroy;
end;

function TJvDBGridExcelExport.IndexFieldToExcel(Index: Integer): string;
begin
  // Max column : ZZ => Index = 702
  if Index > 26 then
    Result := Chr(64 + ((Index - 1) div 26)) + Chr(65 + ((Index - 1) mod 26))
  else
    Result := Chr(64 + Index);
end;

function TJvDBGridExcelExport.DoExport: Boolean;
const
  cExcelApplication = 'Excel.Application';
var
  I, J, K: Integer;
  lTable: OleVariant;
  lCell: OleVariant;
  ARecNo, lRecCount: Integer;
  lBookmark: TBookmark;
begin
  Result := True;
  FRunningInstance := True;
  try
    // get running instance
    FExcel := GetActiveOleObject(cExcelApplication);
  except
    FRunningInstance := False;
    try
      // create new instance
      FExcel := CreateOleObject(cExcelApplication);
    except
      FExcel := Unassigned;
      HandleException;
    end;
  end;

  if VarIsEmpty(FExcel) then
    Exit;
  try
    FExcel.WorkBooks.Add;
    FExcel.Visible := Visible;

    lTable := FExcel.ActiveWorkbook.ActiveSheet;

    if Orientation = woPortrait then
      lTable.PageSetup.Orientation := xlPortrait
    else
      lTable.PageSetup.Orientation := xlLandscape;

    K := 1;
    for I := 0 to FColumnCount - 1 do
      if FRecordColumns[I].Visible then
      begin
        lCell := lTable.Range[IndexFieldToExcel(K) + '1'];
        lCell.Value := FRecordColumns[I].ColumnName;
        Inc(K);
      end;

    J := 1;
    with Grid.DataSource.DataSet do
    begin
      ARecNo := 0;
      lRecCount := RecordCount;
      DoProgress(0, lRecCount, ARecNo, Caption);
      DisableControls;
      lBookmark := GetBookmark;
      First;
      try
        while not Eof do
        begin
          Inc(J);
          K := 1;
          for I := 0 to FColumnCount - 1 do
          begin
            if FRecordColumns[I].Exportable then
            begin
              lCell := lTable.Range[IndexFieldToExcel(K) + IntToStr(J)];
              try
                // Do not cast with string !
                lCell.Value := FRecordColumns[I].Field.Value;
              except
                Result := False;
                HandleException;
              end;
            end;
            if FRecordColumns[I].Visible then
              Inc(K);
          end;
          Next;
          Inc(ARecNo);
          if not DoProgress(0, lRecCount, ARecNo, Caption) then
            Last;
        end;
        if AutoFit then
          try
            lTable.Columns.AutoFit; // NEW! Autofit!
          except
             {$IFDEF DEBUGINFO_ON}
             on E: Exception do
               OutputDebugString(PChar('lTable.Columns.AutoFit failed. ' + E.Message));
             {$ENDIF DEBUGINFO_ON}
          end;
        DoProgress(0, lRecCount, lRecCount, Caption);
      finally
        try
          if BookmarkValid(lBookmark) then
            GotoBookmark(lBookmark);
        except
          HandleException;
        end;
        if lBookmark <> nil then
          FreeBookmark(lBookmark);
        EnableControls;
      end;
    end;
  except
    HandleException;
  end;
end;

procedure TJvDBGridExcelExport.DoSave;
var
  lName: OleVariant;
begin
  inherited DoSave;
  if not VarIsEmpty(FExcel) then
  try
    lName := OleVariant(FileName);
    FExcel.ActiveWorkbook.SaveAs(lName);
  except
    HandleException;
  end;
end;

procedure TJvDBGridExcelExport.DoClose;
begin
  if not VarIsEmpty(FExcel) and (FClose = scNever) then
  begin
    FExcel.Visible := True;
    Exit;
  end;

  if not VarIsEmpty(FExcel) and (FClose <> scNever) then
  try
    FExcel.ActiveWorkbook.Saved := True; // Avoid Excel's save prompt
    if (Close = scAlways) or not FRunningInstance then
    begin
      FExcel.ActiveWorkbook.Close;
      FExcel.Quit;
    end;
    FExcel := Unassigned;
  except
    HandleException;
  end;
end;

//=== { TJvDBGridHTMLExport } ================================================

constructor TJvDBGridHTMLExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDocument := TStringList.Create;
  Caption := RsExportHTML;
  FDocTitle := RsHTMLExportDocTitle;
  FHeader := TStringList.Create;
  FFooter := TStringList.Create;
  FIncludeColumnHeader := True;
  SetDefaultData;
end;

destructor TJvDBGridHTMLExport.Destroy;
begin
  FFooter.Free;
  FHeader.Free;
  FDocument.Free;
  inherited Destroy;
end;

procedure TJvDBGridHTMLExport.SetDefaultData;
begin
  Header.Add('<html><head><title><#TITLE></title>');
  Header.Add('<style type=text/css>');
  Header.Add('#STYLE');
  Header.Add('</style>');
  Header.Add('</head><body>');

  Footer.Add('</body></html>');
end;

function TJvDBGridHTMLExport.GetFooter: TStrings;
begin
  Result := FFooter;
end;

procedure TJvDBGridHTMLExport.SetFooter(const Value: TStrings);
begin
  FFooter.Assign(Value);
end;

function TJvDBGridHTMLExport.GetHeader: TStrings;
begin
  Result := FHeader;
end;

procedure TJvDBGridHTMLExport.SetHeader(const Value: TStrings);
begin
  FHeader.Assign(Value);
end;

procedure TJvDBGridHTMLExport.DoClose;
begin
 // do nothing
end;

function TJvDBGridHTMLExport.DoExport: Boolean;
var
  I: Integer;
  ARecNo, lRecCount: Integer;
  lBookmark: TBookmark;
  lString, lText, lHeader, lStyle: string;

  function AlignmentToHTML(AAlign: TAlignment): string;
  begin
    case AAlign of
      taLeftJustify:
        Result := 'left';
      taRightJustify:
        Result := 'right';
      taCenter:
        Result := 'center';
    end;
  end;

  function ColorToHTML(AColor: TColor): string;
  var
    r, g, b: byte;
  begin
    AColor := ColorToRGB(AColor);
    r := GetRValue(AColor);
    g := GetGValue(AColor);
    b := GetBValue(AColor);
    Result := Format('%.2x%.2x%.2x', [r, g, b]);
  end;

  function FontSubstitute(const Name: string): string;
  const
    cFontKey: array [Boolean] of PChar =
     ('SOFTWARE\Microsoft\Windows\CurrentVersion\FontSubstitutes',
      'SOFTWARE\Microsoft\Windows NT\CurrentVersion\FontSubstitutes');
  begin
    Result := RegReadStringDef(HKEY_LOCAL_MACHINE,
      cFontKey[Win32Platform = VER_PLATFORM_WIN32_NT], Name, Name);
  end;

  function FontSizeToHTML(PtSize: Integer): Integer;
  begin
    case Abs(PtSize) of
      0..8:
        Result := 1;
      9..10:
        Result := 2;
      11..12:
        Result := 3;
      13..17:
        Result := 4;
      18..23:
        Result := 5;
      24..35:
        Result := 6;
    else
      Result := 7;
    end;
  end;

  function FontToHTML(AFont: TFont; EncloseText: string): string;
  begin
    if fsBold in AFont.Style then
      EncloseText := '<b>' + EncloseText + '</b>';
    if fsItalic in AFont.Style then
      EncloseText := '<i>' + EncloseText + '</i>';
    if fsUnderline in AFont.Style then
      EncloseText := '<u>' + EncloseText + '</u>';
    if fsStrikeout in AFont.Style then
      EncloseText := '<s>' + EncloseText + '</s>';
    Result := Format('<font face="%s" color="#%s" size="%d">%s</font>',
      [FontSubstitute(AFont.Name), ColorToHTML(AFont.Color), FontSizeToHTML(AFont.Size), EncloseText]);
  end;

  function FontStyleToHTML(AFont: TFont): string;
  begin
    Result := '';
    if fsBold in AFont.Style then
      Result := 'FONT-WEIGHT: bold; ';
    if fsItalic in AFont.Style then
      Result := Result + 'FONT-STYLE: italic; ';
    if fsUnderline in AFont.Style then
      if fsStrikeout in AFont.Style then
        Result := Result + 'TEXT-DECORATION: underline line-through; '
      else
        Result := Result + 'TEXT-DECORATION: underline; '
    else