this slowpoke moves

Export StringGrid to Bitmap

uses Grids

//

function GridToBmp(SG: TStringGrid;Fixed: Boolean;Bmp: TBitmap;Border: Integer;BorderColor: TColor): Boolean;

var oldGridRect : TGridRect;
    oldLeftCol, oldTopRow : LongInt;
    oldFixedCols, oldfixedRows,
    xSum, ySum,
    z : Integer;
    RectGrid, RectTemp, RectBmp : TRect;
  //****************************************************************************
  {} procedure NextHorzRange(RangeRowBeginn,RangeRowEnd: Integer);
  {} begin
  {}   with SG do
  {}     begin
  {}     LeftCol := LeftCol+VisibleColCount;
  {}     Repaint;
  {}     RectGrid := CellRect(LeftCol,RangeRowBeginn);
  {}     RectTemp := CellRect(LeftCol+VisibleColCount-1,RangeRowEnd+VisibleRowCount-1);
  {}     RectGrid.Right := RectTemp.Right+1;
  {}     RectGrid.Bottom := RectTemp.Bottom+1;
  {}     RectBmp.Left := RectBmp.Right;
  {}     RectBmp.Right := RectBmp.Right+RectGrid.Right-RectGrid.Left;
  {}     Bmp.Canvas.CopyRect(rectBmp,Canvas,RectGrid);
  {}     end;
  {} end;
  //****************************************************************************
begin
  xSum := 0;
  ySum := 0;
  with SG do
    begin
    oldGridRect := Selection;
    oldLeftCol := LeftCol;
    oldTopRow := TopRow;
    if Fixed = False then
      begin
      oldFixedCols := FixedCols;
      oldFixedRows := FixedRows;
      FixedCols := 0;
      FixedRows := 0;
      end;
    Selection:= TGridRect(Rect(-1,-1,-1,-1));
    for z := 0 to ColCount-1 do
      inc(xSum,ColWidths[z]+1);
    for z := 0 to RowCount-1 do
      inc(ySum,RowHeights[z]+1);
    try//except
      Bmp.Width := xSum+(Border*2);
      Bmp.Height := ySum+(Border*2);
      Bmp.Canvas.Pen.Color := BorderColor;
      Bmp.Canvas.Brush.Color := BorderColor;
      Bmp.Canvas.Rectangle(0,0,Bmp.Width,Bmp.Height);
      //ersten horizontalen Bereich bearbeiten
      LeftCol := FixedCols;
      TopRow := FixedRows;
      Repaint;
      RectGrid := CellRect(0,0);
      RectTemp := CellRect(FixedCols+VisibleColCount-1,FixedRows+VisibleRowCount-1);
      RectGrid.Right := RectTemp.Right+1;
      RectGrid.Bottom := RectTemp.Bottom+1;
      RectBmp.Left := Border;
      RectBmp.Top := Border;
      RectBmp.Right := RectGrid.Right+Border;
      RectBmp.Bottom := RectGrid.Bottom+Border;
      Bmp.Canvas.CopyRect(RectBmp,Canvas,RectGrid);
      while LeftCol+VisibleColCount < ColCount do
        NextHorzRange(0,FixedRows);
      //weitere horizontale Bereiche bis Ende StringGrid bearbeiten
      while TopRow+VisibleRowCount < RowCount do
        begin
        LeftCol := FixedCols;
        TopRow := TopRow+VisibleRowCount;
        Repaint;
        RectGrid := CellRect(0,TopRow);
        RectTemp := CellRect(FixedCols+VisibleColCount-1,TopRow+VisibleRowCount-1);
        RectGrid.Right := RectTemp.Right+1;
        RectGrid.Bottom := RectTemp.Bottom+1;
        RectBmp.Top := RectBmp.Bottom;
        RectBmp.Left := Border;
        RectBmp.Right := RectGrid.Right+Border;
        RectBmp.Bottom := RectBmp.Top+RectGrid.Bottom-RectGrid.Top;
        Bmp.Canvas.CopyRect(RectBmp,Canvas,RectGrid);
        while LeftCol+VisibleColCount < ColCount do
          NextHorzRange(TopRow,TopRow);
        end;
      LeftCol := oldLeftCol;
      TopRow := oldTopRow;
      if Fixed = False then
        begin
        FixedCols := oldFixedCols;
        FixedRows := oldFixedRows;
        end;
      Selection := oldGridRect;
      Result := True;
    except
      on e:EOutOfResources do
        begin
        Result := False;
        showmessage('EOutOfResources: Bitmap konnte nicht erstellt werden');
        end
        else
          begin 
          Result := False;
          showmessage('Unbekannter Fehler');
          end;
    end;//Ende except
  end;//Ende with
end;
Beispiel :
procedure TForm1.Button1Click(Sender: TObject);
var Bmp : TBitmap;
begin
  Bmp := TBitmap.Create;
  if GridToBmp(StringGrid1, True, Bmp, 1, clBlack) then
    begin
    Image1.Picture.Bitmap.Assign(Bmp);
    //oder
    //Bmp.SaveToFile('C:\Temp.bmp');
    //Clipboard.Assign(Bmp); //in uses clipbrd einbinden !!!
    end;
  Bmp.Free;
end;

Keine Kommentare:

Kommentar veröffentlichen

Beliebte Posts

Translate