StringGrid

Code:

// Getting a TScrollbar control to Show a proportional thumb:

procedure TForm1.Button1Click(Sender: TObject);

var

  info: TScrollInfo;

begin

  FillChar(info, SizeOf(info), 0);

  with info do

  begin

    cbsize := SizeOf(info);

    fmask  := SIF_PAGE;

    nPage  := ScrollBar1.LargeChange;

  end;

  SetScrollInfo(ScrollBar1.Handle, SB_CTL, info, True);

end;

// Same for a TStringGrid

procedure TForm1.Button1Click(Sender: TObject);

var

  info: TScrollInfo;

begin

  FillChar(info, SizeOf(info), 0);

  with info do

  begin

    cbsize := SizeOf(info);

    fmask  := SIF_ALL;

    GetScrollInfo(StringGrid1.Handle, SB_VERT, info);

    fmask := fmask or SIF_PAGE;

    nPage := 5 * (nmax - nmin) div StringGrid1.RowCount;

    // whatever number of cells you consider a "page"

end;

  SetScrollInfo(StringGrid1.Handle, SB_VERT, info, True);

end;

Code:

if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_VSCROLL) <> 0 then

  ShowMessage('Vertical scrollbar is visible!');

if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_HSCROLL) <> 0 then

  ShowMessage('Horizontal scrollbar is visible!');

Code:

Procedure GridSort(StrGrid: TStringGrid; NoColumn: Integer);

Var Line, PosActual: Integer;

   Row: TStrings;

begin

Renglon := TStringList.Create;

For Line := 1 to StrGrid.RowCount-1 do

Begin

   PosActual := Line;

   Row.Assign(TStringlist(StrGrid.Rows[PosActual]));

   While True do

   Begin

     If (PosActual = 0) Or (StrToInt(Row.Strings[NoColumn-1]) >=

         StrToInt(StrGrid.Cells[NoColumn-1,PosActual-1])) then

       Break;

     StrGrid.Rows[PosActual] := StrGrid.Rows[PosActual-1];

     Dec(PosActual);

   End;

   If StrToInt(Row.Strings[NoColumn-1]) < StrToInt(StrGrid.Cells[NoColumn-1,PosActual]) then

     StrGrid.Rows[PosActual] := Row;

End;

Renglon.Free;

end;

Code:

uses

  {...} Grids;

type

  TForm1 = class(TForm)

    StringGrid1: TStringGrid;

    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;

      Rect: TRect; State: TGridDrawState);

  end;

{...}

implementation

{...}

// Display text vertically in StringGrid cells

// Vertikale Textausgabe in den Zellen eines StringGrid

procedure StringGridRotateTextOut(Grid: TStringGrid; ARow, ACol: Integer; Rect: TRect;

  Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);

var

  lf: TLogFont;

  tf: TFont;

begin

  // if the font is to big, resize it

// wenn Schrift zu gro? dann anpassen

if (Size > Grid.ColWidths[ACol] div 2) then

    Size := Grid.ColWidths[ACol] div 2;

  with Grid.Canvas do

  begin

    // Replace the font

   // Font setzen

   Font.Name := Schriftart;

    Font.Size := Size;

    Font.Color := Color;

    tf := TFont.Create;

    try

      tf.Assign(Font);

      GetObject(tf.Handle, SizeOf(lf), @lf);

      lf.lfEscapement  := 900;

      lf.lfOrientation := 0;

      tf.Handle := CreateFontIndirect(lf);

      Font.Assign(tf);

    finally

      tf.Free;

    end;

    // fill the rectangle

   // Rechteck fullen

   FillRect(Rect);

    // Align text and write it

   // Text nach Ausrichtung ausgeben

   if Alignment = taLeftJustify then

      TextRect(Rect, Rect.Left + 2,Rect.Bottom - 2,Grid.Cells[ACol, ARow]);

    if Alignment = taCenter then

      TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size +

        Size div 3,Rect.Bottom - 2,Grid.Cells[ACol, ARow]);

    if Alignment = taRightJustify then

      TextRect(Rect, Rect.Right - Size - Size div 2 - 2,Rect.Bottom -

        2,Grid.Cells[ACol, ARow]);

  end;

end;

// 2. Alternative: Display text vertically in StringGrid cells

// 2. Variante: Vertikale Textausgabe in den Zellen eines StringGrid

procedure StringGridRotateTextOut2(Grid:TStringGrid;ARow,ACol:Integer;Rect:TRect;

          Schriftart:String;Size:Integer;Color:TColor;Alignment:TAlignment);

var

    NewFont, OldFont : Integer;

    FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;

begin

   // if the font is to big, resize it

  // wenn Schrift zu gro? dann anpassen

  If (Size > Grid.ColWidths[ACol] DIV 2) Then

       Size := Grid.ColWidths[ACol] DIV 2;

   with Grid.Canvas do

   begin

       // Set font

      // Font setzen

      If (fsBold IN Font.Style) Then

          FontStyle := FW_BOLD

       Else

          FontStyle := FW_NORMAL;

       If (fsItalic IN Font.Style) Then

          FontItalic := 1

       Else

          FontItalic := 0;

       If (fsUnderline IN Font.Style) Then

          FontUnderline := 1

       Else

          FontUnderline := 0;

       If (fsStrikeOut IN Font.Style) Then

          FontStrikeout:=1

       Else

          FontStrikeout:=0;

       Font.Color := Color;

       NewFont := CreateFont(Size, 0, 900, 0, FontStyle, FontItalic,

                             FontUnderline, FontStrikeout, DEFAULT_CHARSET,

                             OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,

                             DEFAULT_PITCH, PChar(Schriftart));

       OldFont := SelectObject(Handle, NewFont);

       // fill the rectangle

      // Rechteck fullen

      FillRect(Rect);

       // Write text depending on the alignment

      // Text nach Ausrichtung ausgeben

      If Alignment = taLeftJustify Then

          TextRect(Rect,Rect.Left+2,Rect.Bottom-2,Grid.Cells[ACol,ARow]);

       If Alignment = taCenter Then

          TextRect(Rect,Rect.Left+Grid.ColWidths[ACol] DIV 2 - Size + Size DIV 3,

            Rect.Bottom-2,Grid.Cells[ACol,ARow]);

       If Alignment = taRightJustify Then

          TextRect(Rect,Rect.Right-Size - Size DIV 2 - 2,Rect.Bottom-2,Grid.Cells[ACol,ARow]);

       // Recreate reference to the old font

      // Referenz auf alten Font wiederherstellen

      SelectObject(Handle, OldFont);

       // Recreate reference to the new font

      // Referenz auf neuen Font loschen

      DeleteObject(NewFont);

   end;

end;

// Call the method in OnDrawCell

// Methode im OnDrawCell aufrufen

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol,

  ARow: Integer; Rect: TRect; State: TGridDrawState);

begin

  // In the second column: Rotate Text by 90° and left align the text

// Text um 90°gedreht ausgeben, linksbundig in der zweiten Spalte

if ACol = 1 then

    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL',

      12,clRed, taLeftJustify);

  // In the third column: Center the text

// Ausgabe zentriert in der dritten Spalte

if ACol = 2 then

    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue, taCenter);

  // In all other columns third row: right align the text

// Ausgabe rechtsbundig in den restlichen Spalten

if ACol > 2 then

    StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12,clGreen,

      taRightJustify);

end;

end.

Code:

procedure SGridToHtml(SG: TStringgrid; Dest: TMemo; BorderSize: Integer);

var

i, p: integer;

SStyle1, SStyle2, Text: string;

begin

Dest.Clear;

Dest.Lines.Add('<html>');

Dest.Lines.Add('<body>');

Dest.Lines.Add('  <table border="' + IntToStr(BorderSize) + '" width="' +

   IntToStr(SG.Width) + '" height="' + IntToStr(SG.Width) + '">');

for i := 0 to SG.RowCount - 1 do

begin

   Dest.Lines.Add('  <tr>');

   for p := 0 to SG.ColCount - 1 do

   begin

     SStyle1 := '';

     SStyle2 := '';

     if fsbold in SG.Font.Style then

     begin

       SStyle1 := SStyle1 + '<b>';

       SStyle2 := SStyle2 + '</b>';

     end;

     if fsitalic in SG.Font.Style then

     begin

       SStyle1 := SStyle1 + '<i>';

       SStyle2 := SStyle2 + '</i>';

     end;

     if fsunderline in SG.Font.Style then

     begin

       SStyle1 := SStyle1 + '<u>';

       SStyle2 := SStyle2 + '</u>';

     end;

     Text := sg.Cells[p, i];

     if Text = '' then Text := ' ';

     Dest.Lines.Add('    <td width="' + IntToStr(sg.ColWidths[p]) +

       '" height="' + IntToStr(sg.RowHeights[p]) +

       '"><font color="#' + IntToHex(sg.Font.Color, 6) +

       '" face="' + SG.Font.Name + '">' + SStyle1 +

       Text + SStyle2 + '</font></td>');

   end;

   Dest.Lines.Add('  </tr>');

end;

Dest.Lines.Add('  </table>');

Dest.Lines.Add('</body>');;

Dest.Lines.Add('</html>');

end;

// Example, Beispiel

procedure TFormCSVInport.Button6Click(Sender: TObject);

begin

SGridToHtml(StringGrid1, Memo1, 1);

Memo1.Lines.SaveToFile('c:\test.html');

end;

Code:

procedure TForm1.Button1Click(Sender: TObject);

var K: Double;

begin

Printer.BeginDoc;

K :=  Printer.Canvas.Font.PixelsPerInch / Canvas.Font.PixelsPerInch*1.2;

PrintStringGrid(StrGrid,

K,  // Коэффициент

200, // отступ от края листа в пихелах по Х

200, // --"-- по Y

200 // отступ снизу

);

Printer.EndDoc;

end;

{----------------------------------------------------------}

unit GrdPrn3;

interface

uses

Windows, Classes, Graphics, Grids, Printers, SysUtils;

const

OrdinaryLineWidth: Integer = 2;

BoldLineWidth: Integer = 4;

procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,

TopMargin, BottomMargin:

Integer);

function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,

LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;

// возвращает номер строки, которая не поместилась до Y = Yfloor

// не проверяет, вылезает ли общая длина таблицы за пределы страницы

// Слишком длинное слово обрежется

implementation

procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,

TopMargin, BottomMargin: Integer);

var NextRow: Integer;

begin

//Printer.BeginDoc;

if not Printer.Printing then raise Exception.Create('function

PrintStringGrid must be called between Printer.BeginDoc

  and Printer.EndDoc');

NextRow := 0;

repeat

NextRow := DrawStringGridEx(Grid, Scale, NextRow, LeftMargin, TopMargin,

  Printer.PageHeight - BottomMargin, Printer.Canvas);

if NextRow <> -1 then Printer.NewPage;

until NextRow = -1;

//Printer.EndDoc;

end;

function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,

LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;

// возвращает номер строки, которая не поместилась до Y = Yfloor

var

i, j, d, TotalPrevH, TotalPrevW, CellH, CellW, LineWidth: Integer;

R: TRect;

s: string;

procedure CorrectCellHeight(ARow: Integer);

// вычисление правильной высоты ячейки с учетом многострочного текста

// Текст рабивается только по словам слишком длинное слово обрубается

var

  i, H: Integer;

  R: TRect;

  s: string;

begin

  R := Rect(0, 0, CellH*2, CellH);

  s := ':)'; // Одинарная высота строки

  CellH := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,

    DT_LEFT or DT_TOP or DT_WORDBREAK or DT_SINGLELINE or

    DT_NOPREFIX or DT_CALCRECT) + 3*d;

  for i := 0 to Grid.ColCount-1 do

  begin

   CellW := Round(Grid.ColWidths[i]*Scale);

   R := Rect(0, 0, CellW, CellH);

   //InflateRect(R, -d, -d);

   R.Left := R.Left+d;

   R.Top := R.Top + d;

   s := Grid.Cells[i, ARow];

   // Вычисление ширины и высоты

   H := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,

    DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX or DT_CALCRECT);

текста

   if CellH < H + 2*d then CellH := H + 2*d;

   // if CellW < R.Right - R.Left then Слишком длинное слово -

   // не помещается в одну строку; Перенос слов не поддерживается

  end;

end;

begin

Result := -1; // все строки уместились между TopMargin и Yfloor

if (FromRow < 0)or(FromRow >= Grid.RowCount) then Exit;

DestCanvas.Brush.Style := bsClear;

DestCanvas.Font := Grid.Font;

//  DestCanvas.Font.Height := Round(Grid.Font.Height*Scale);

DestCanvas.Font.Size := 10;

Grid.Canvas.Font := Grid.Font;

Scale := DestCanvas.TextWidth('test')/Grid.Canvas.TextWidth('test');

d := Round(2*Scale);

TotalPrevH := 0;

for j := 0 to Grid.RowCount-1 do

begin

if (j >= Grid.FixedRows) and (j < FromRow) then Continue;

// Fixed Rows рисуются на каждой странице

TotalPrevW := 0;

CellH := Round(Grid.RowHeights[j]*Scale);

CorrectCellHeight(j);

if TopMargin + TotalPrevH + CellH > YFloor then

begin

  Result := j; // j-я строка не помещается в заданный диапазон

  if Result < Grid.FixedRows then Result := -1;

  // если фиксированные строки не влезают на страницу -

  // это тяж?лый случай...

  Exit;

end;

for i := 0 to Grid.ColCount-1 do

begin

  CellW := Round(Grid.ColWidths[i]*Scale);

  R := Rect(TotalPrevW, TotalPrevH, TotalPrevW + CellW,

    otalPrevH + CellH);

  OffSetRect(R, LeftMargin, TopMargin);

  if (i < Grid.FixedCols)or(j < Grid.FixedRows) then

    LineWidth := BoldLineWidth

  else

    LineWidth := OrdinaryLineWidth;

  DestCanvas.Pen.Width := LineWidth;

  if LineWidth > 0 then

   DestCanvas.Rectangle(R.Left, R.Top, R.Right+1, R.Bottom+1);

  //InflateRect(R, -d, -d);

  R.Left := R.Left+d;

  R.Top := R.Top + d;

  s := Grid.Cells[i, j];

  DrawText(DestCanvas.Handle, PChar(s), Length(s), R,

   DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX);

  TotalPrevW := TotalPrevW + CellW; // Общая ширина всех предыдущих колонок

end;

TotalPrevH := TotalPrevH + CellH;  // Общая высота всех предыдущих строк

end;

end;

end.

Code:

procedure TForm1.DrawGrid1DrawCell(Sender: TObject; Col, Row: Longint;

Rect: TRect; State: TGridDrawState);

var

vRow, vCol: LongInt;

begin

vRow := Row;

vCol := Col;

with Sender as TDrawGrid, Canvas do

begin

   if (vRow = 0) or (vCol = 0) then

     Font.Color := clBlack

   else

     Font.Color := clRed;

   TextRect(Rect, Rect.Left, Rect.Top, Format('(%d,%d)', [vRow, vCol]));

end;

end;

Code:

function Xls_To_StringGrid(AGrid: TStringGrid; AXLSFile: string): Boolean;

const

xlCellTypeLastCell = $0000000B;

var

XLApp, Sheet: OLEVariant;

RangeMatrix: Variant;

x, y, k, r: Integer;

begin

Screen.Cursor:=crAppStart;

Result := False;

XLApp := CreateOleObject('Excel.Application');

try

   XLApp.Visible := False;

   XLApp.Workbooks.Open(AXLSFile);

   Sheet := XLApp.Workbooks[ExtractFileName(AXLSFile)].WorkSheets[1];

   Sheet.Cells.SpecialCells(xlCellTypeLastCell, EmptyParam).Activate;

   x := XLApp.ActiveCell.Row;

   y := XLApp.ActiveCell.Column;

   AGrid.RowCount := x;

   AGrid.ColCount := y; 

   RangeMatrix := XLApp.Range['A1', XLApp.Cells.Item[X, Y]].Value;

   k := 1;

   repeat

     for r := 1 to y do

      AGrid.Cells[(r - 1), (k - 1)] := RangeMatrix[K, R];

     Inc(k, 1);

     AGrid.RowCount := k + 1; 

   until k > x; 

   RangeMatrix := Unassigned;

finally

   if not VarIsEmpty(XLApp) then

   begin

     XLApp.Quit; 

     XLAPP := Unassigned; 

     Sheet := Unassigned; 

     Result := True; 

   end; 

end;

Screen.Cursor:=crDefault;

end;