rm_grid.pas

进销存·完整的·有数据库的·非常完整·只得参考

    StartPos, EndPos: Integer;
  end;

{ TRMGridEx }

constructor TRMGridEx.Create(AOwner: TComponent);
const
  GridStyle = [csCaptureMouse, csOpaque, csDoubleClicks];
begin
  inherited Create(AOwner);
  if NewStyleControls then
    ControlStyle := GridStyle
  else
    ControlStyle := GridStyle + [csFramed];

  FCanEditModify := True;
  FColCount := 10;
  FRowCount := 6;
  FFixedCols := 1;
  FFixedRows := 1;
  FGridLineWidth := 1;
  FDefaultColWidth := 64;
  FDefaultRowHeight := 24;
  FOptions := [rmgoFixedVertLine, rmgoFixedHorzLine, rmgoVertLine, rmgoHorzLine,
    rmgoRangeSelect, rmgoRowSizing, rmgoColSizing, rmgoDrawFocusSelected];
  FScrollBars := ssBoth;
  FBorderStyle := bsSingle;
  FSaveCellExtents := True;
  ParentColor := False;
  TabStop := True;
  FDefaultDrawing := True;
  FAutoDraw := True;

  Color := clWindow;
  FFixedColor := clBtnFace;
  FTitleColor := clBtnFace;
  FHighLightColor := clBlack;
  FHighLightTextColor := clWhite;
  FFocusedTitleColor := clBlack;
  FFixedLineColor := clBlack;
  FClientLineColor := clSilver;

  FAutoUpdate := True;
  FGridCanCopyMove := False;
  FGridCanFill := False;

  Font.Name := '宋体';
  Font.Size := 10;
  Font.Charset := RMCharset;
  FCells := TRMCells.Create(FColCount, FRowCount, Self);
  SetBounds(Left, Top, FColCount * FDefaultColWidth, FRowCount * FDefaultRowHeight);
  Initialize;
end;

destructor TRMGridEx.Destroy;
begin
  FAutoDraw := False;
  FCells.Free;
  inherited Destroy;
  FreeMem(FColWidths);
  FreeMem(FRowHeights);
end;

procedure TRMGridEx.CreateViewsName;
var
  liCol, liRow, i, j: Integer;
  sl: TStringList;
  liPage: TRMPage;
  liCell: TRMCellInfo;
  liName: string;
begin
  sl := TStringList.Create;
  Name := '';
  try
    for i := 0 to CurReport.Pages.Count - 1 do
    begin
      liPage := CurReport.Pages[i];
      for j := 0 to liPage.Objects.Count - 1 do
      begin
        sl.Add(UpperCase(TRMView(liPage.Objects[j]).Name));
        THackView(liPage.Objects[j]).AddChildView(sl);
      end;
    end;

    sl.Sort;
    i := 0;
    for liRow := 1 to RowCount - 1 do
    begin
      for liCol := 1 to ColCount - 1 do
      begin
        liCell := Cells[liCol, liRow];
        if liCell.View.Name = '' then
        begin
          Inc(i);
          while i < 10000 do
          begin
            liName := THackView(liCell.View).BaseName + IntToStr(i);
            if not sl.Find(UpperCase(liName), j) then
            begin
              liCell.View.Name := liName;
              Break;
            end;
            Inc(i);
          end;
        end;
      end;
    end;
  finally
    sl.Free;
  end;
end;

function TRMGridEx.GetCellInfo(ACol, Arow: Integer): TRMCellinfo;
var
  liCell: TRMCellInfo;
begin
  liCell := Cells[ACol, ARow];
  Result := Cells[liCell.StartCol, liCell.StartRow];
end;

function TRMGridEx.BoxRect(ALeft, ATop, ARight, ABottom: Longint): TRect;
var
  GridRect: TRect;
begin
  GridRect.Left := ALeft;
  GridRect.Right := ARight;
  GridRect.Top := ATop;
  GridRect.Bottom := ABottom;
  GridRectToScreenRect(GridRect, Result, False);
end;

function TRMGridEx.CellRect(ACol, ARow: Longint): TRect;
begin
  Result := BoxRect(ACol, ARow, ACol, ARow);
end;

function TRMGridEx.IsActiveControl: Boolean;
var
  H: Hwnd;
  ParentForm: TCustomForm;
begin
  Result := False;
  ParentForm := GetParentForm(Self);
  if Assigned(ParentForm) then
  begin
    if (ParentForm.ActiveControl = Self) then
      Result := True
  end
  else
  begin
    H := GetFocus;
    while IsWindow(H) and (Result = False) do
    begin
      if H = WindowHandle then
        Result := True
      else
        H := GetParent(H);
    end;
  end;
end;

function TRMGridEx.MouseCoord(X, Y: Integer): TPoint;
var
  DrawInfo: TRMGridDrawInfo;
begin
  CalcDrawInfo(DrawInfo);
  Result := CalcCoordFromPoint(X, Y, DrawInfo);
  if Result.X < 0 then
    Result.Y := -1
  else if Result.Y < 0 then
    Result.X := -1;
end;

procedure TRMGridEx.MoveColRow(ACol, ARow: Longint; MoveAnchor,
  Show: Boolean);
begin
  MoveCurrent(ACol, ARow, MoveAnchor, Show);
end;

function TRMGridEx.SelectCell(ACol, ARow: Longint): Boolean;
begin
  Result := True;
  if Assigned(FOnSelectCell) then
    FOnSelectCell(Self, ACol, ARow, Result);
end;

procedure TRMGridEx.SizeChanged(OldColCount, OldRowCount: Longint);
begin
end;

function TRMGridEx.Sizing(X, Y: Integer): Boolean;
var
  DrawInfo: TRMGridDrawInfo;
  State: TRMGridState;
  Index: Longint;
  Pos, Ofs: Integer;
begin
  State := FGridState;
  if State = rmgsNormal then
  begin
    CalcDrawInfo(DrawInfo);
    CalcSizingState(X, Y, State, Index, Pos, Ofs, DrawInfo);
  end;
  Result := State <> rmgsNormal;
end;

procedure TRMGridEx.TopLeftChanged;
begin
end;

procedure FillDWord(var Dest; Count, Value: Integer); register;
asm
  XCHG  EDX, ECX
  PUSH  EDI
  MOV   EDI, EAX
  MOV   EAX, EDX
  REP   STOSD
  POP   EDI
end;

{ StackAlloc allocates a 'small' block of memory from the stack by
  decrementing SP.  This provides the allocation speed of a local variable,
  but the runtime size flexibility of heap allocated memory.  }

function StackAlloc(Size: Integer): Pointer; register;
asm
  POP   ECX          { return address }
  MOV   EDX, ESP
  ADD   EAX, 3
  AND   EAX, not 3   // round up to keep ESP dword aligned
  CMP   EAX, 4092
  JLE   @@2
@@1:
  SUB   ESP, 4092
  PUSH  EAX          { make sure we touch guard page, to grow stack }
  SUB   EAX, 4096
  JNS   @@1
  ADD   EAX, 4096
@@2:
  SUB   ESP, EAX
  MOV   EAX, ESP     { function result = low memory address of block }
  PUSH  EDX          { save original SP, for cleanup }
  MOV   EDX, ESP
  SUB   EDX, 4
  PUSH  EDX          { save current SP, for sanity check  (sp = [sp]) }
  PUSH  ECX          { return to caller }
end;

procedure StackFree(P: Pointer); register;
asm
  POP   ECX                     { return address }
  MOV   EDX, DWORD PTR [ESP]
  SUB   EAX, 8
  CMP   EDX, ESP                { sanity check #1 (SP = [SP]) }
  JNE   @@1
  CMP   EDX, EAX                { sanity check #2 (P = this stack block) }
  JNE   @@1
  MOV   ESP, DWORD PTR [ESP+4]  { restore previous SP  }
@@1:
  PUSH  ECX                     { return to caller }
end;

procedure TRMGridEx.SetClipRect(ACanvas: TCanvas; ClipR: TRect);
begin
  FOldRgn := 0;
  FOldRgn := CreateRectRgn(0, 0, 0, 0);
  FHaveClip := GetClipRgn(ACanvas.Handle, FOldRgn);

  FNewRgn := CreateRectRgnIndirect(ClipR);
  SelectClipRgn(ACanvas.Handle, FNewRgn);
  DeleteObject(FNewRgn);
end;

procedure TRMGridEx.RestoreClipRect(ACanvas: TCanvas);
begin
  if FHaveClip > 0 then
    SelectClipRgn(ACanvas.Handle, FOldRgn)
  else
    SelectClipRgn(ACanvas.Handle, 0);
  DeleteObject(FOldRgn);
end;

procedure TRMGridEx.ShowFrame(t: TRMView; aCanvas: TCanvas; x, y, x1, y1: Integer);

  procedure Line1(x, y, x1, y1: Integer);
  begin
    aCanvas.MoveTo(x, y);
    aCanvas.LineTo(x1, y1);
  end;

  procedure DrawFrame(const x, y, x1, y1: Integer; b: TRMFrameLine; aFlag: Byte);
  begin
    aCanvas.Pen.Width := Round(b.Width);
    aCanvas.Pen.Style := TPenStyle(b.Style and not rmftDouble);
    aCanvas.Pen.Color := b.Color;
    aCanvas.MoveTo(x, y);
    aCanvas.LineTo(x1, y1);
  end;

begin
  if t.LeftFrame.Visible then
    Inc(x, Round(t.LeftFrame.Width) div 2 - 1);
  if t.TopFrame.Visible then
    Inc(y, Round(t.TopFrame.Width) div 2 - 1);
  if t.RightFrame.Visible then
    Dec(x1, Round(t.RightFrame.Width) div 2);
  if t.BottomFrame.Visible then
    Dec(y1, Round(t.BottomFrame.Width) div 2);

  if t.LeftFrame.Visible then
    DrawFrame(x, y, x, y1, t.LeftFrame, 1);
  if t.TopFrame.Visible then
    DrawFrame(x, y, x1, y, t.TopFrame, 2);
  if t.RightFrame.Visible then
    DrawFrame(x1, y, x1, y1, t.RightFrame, 3);
  if t.BottomFrame.Visible then
    DrawFrame(x, y1, x1, y1, t.BottomFrame, 4);

  if t.LeftRightFrame > 0 then
  begin
    aCanvas.Brush.Style := bsSolid;
    aCanvas.Pen.Style := psSolid;
    aCanvas.Pen.Width := 1;
    aCanvas.Pen.Color := t.LeftFrame.Color;
    case t.LeftRightFrame of
      1: Line1(x, y, x1, y1);
      2:
        begin
          Line1(x, y, x1 div 2, y1);
          Line1(x, y, x1, y1 div 2);
        end;
      3:
        begin
          Line1(x, y, x1, y1);
          Line1(x, y, x1 div 2, y1);
          Line1(x, y, x1, y1 div 2);
        end;
      4: Line1(x, y1, x1, y);
      5:
        begin
          Line1(x, y1 div 2, x1, y);
          Line1(x1 div 2, y1, x1, y);
        end;
      6:
        begin
          Line1(x, y1, x1, y);
          Line1(x, y1 div 2, x1, y);
          Line1(x1 div 2, y1, x1, y);
        end;
    end;
  end;
end;

procedure TRMGridEx.DrawCell(ACol, ARow: Longint; ARect, AClipRect: TRect; AState: TRMGridDrawState);
var
  liTextAlignMode: UINT;
  liTextToDraw: PChar;
  liTestRect: TRect; // 边框范围与文本试输出范围
  liTestWidth, liTestHeight: Integer; // 实际宽高
  liDrawWidth, liDrawHeight: Integer; // 绘画区宽高

  procedure CalcTestRect;
  var
    CalcMode: Cardinal;
  begin
    liTestRect := ARect;
    with liTestRect do
    begin
      Dec(Right, Left);
      Dec(Bottom, Top);
      Left := 0;
      Top := 0;
    end;
    CalcMode := DT_CALCRECT;
    if Cells[ACol, ARow].AutoWordBreak then
      CalcMode := CalcMode or DT_WORDBREAK;
    DrawText(Canvas.Handle, liTextToDraw, -1, liTestRect, CalcMode);
    liTestWidth := liTestRect.Right - liTestRect.Left;
    liTestHeight := liTestRect.Bottom - liTestRect.Top;
    liDrawWidth := ARect.Right - ARect.Left;
    liDrawHeight := ARect.Bottom - ARect.Top;
    liTestRect.Left := (liDrawWidth - liTestWidth) div 2;
    liTestRect.Right := liTestRect.Left + liTestWidth;
    liTestRect.Top := (liDrawHeight - liTestHeight) div 2;
    liTestRect.Bottom := liTestRect.Top + liTestHeight;
  end;

begin
  if (aCol > 0) and (aRow > 0) then
    ShowFrame(Cells[ACol, ARow].View, Canvas, aRect.Left, aRect.Top, aRect.Right, aRect.Bottom);

  if (ARow = 0) and (ACol <> 0) then
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Font.Name := 'MS Sans Serif';
    Canvas.Font.Size := 8;
    Canvas.Font.Style := [];
    Canvas.Font.Color := clWindowText;
    DrawText(Canvas.Handle, PChar(ColTitle(ACol - 1)), -1, ARect, DT_CENTER or DT_VCENTER or DT_SINGLELINE)
  end
  else if (ACol = 0) and (ARow <> 0) then
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Font.Name := 'MS Sans Serif';
    Canvas.Font.Size := 8;
    Canvas.Font.Style := [];
    Canvas.Font.Color := clWindowText;
    DrawText(Canvas.Handle, PChar(IntToStr(ARow)), -1, ARect, DT_CENTER or DT_VCENTER or DT_SINGLELINE)
  end
  else if (ARow <> 0) and (ACol <> 0) then
  begin
    InflateRect(ARect, -1, -1);
    IntersectClipRect(Canvas.Handle, ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
    with Cells[ACol, ARow] do
    begin
      if Text <> '' then
      begin
        liTextToDraw := PChar(Text);
        Canvas.Font.Assign(Font);
        if rmgdSelected in AState then //and ((ACol <> FCurrent.X) or (ARow <> FCurrent.Y)) then
          Canvas.Font.Color := FHighLightTextColor;

        CalcTestRect;