rm_grid.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,110 行 · 第 1/5 页

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 := b.Style;
    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;
    aRect.Right := aRect.Right - 2;
    liTestRect := Rect(ARect.Left + 2, ARect.Top + 2, ARect.Right, ARect.Bottom);
    DrawText(Canvas.Handle, PChar(IntToStr(ARow)), -1, liTestRect, DT_LEFT or DT_TOP or DT_SINGLELINE);
    DrawText(Canvas.Handle, PChar(Cells[0, aRow].Text), -1, aRect, DT_RIGHT {DT_CENTER} or DT_VCENTER or DT_SINGLELINE)
      //    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;
        case HAlign of
          rmHLeft: liTextAlignMode := DT_TOP or DT_LEFT;
          rmHRight: liTextAlignMode := DT_TOP or DT_RIGHT;
        else
          liTextAlignMode := DT_CENTER;
        end;
        case VAlign of
          rmVBottom: ARect.Top := ARect.Bottom - liTestHeight;
          rmVCenter: Inc(ARect.Top, liTestRect.Top);
        end;
        if AutoWordBreak then
          liTextAlignMode := liTextAlignMode or DT_WORDBREAK;
        Windows.DrawText(Canvas.Handle, liTextToDraw, -1, ARect, liTextAlignMode)
      end;
    end;
    RestoreClipRect(Canvas);
    SetClipRect(Canvas, AClipRect);
  end;

  //  if Assigned(FOnDrawCell) then
  //  begin
  //    FOnDrawCell(Self, ACol, ARow, ARect, AState);
  //  end;
end;

{$IFNDEF Delphi4}

function Max(Value1, Value2: Integer): Integer;
begin
  if Value1 > Value2 then
    Result := Value1
  else
    Result := Value2;
end;

function Min(Value1, Value2: Integer): Integer;
begin
  if Value1 > Value2 then
    Result := Value2
  else
    Result := Value1;
end;
{$ENDIF}

procedure TRMGridEx.Paint;
var
  DrawInfo: TRMGridDrawInfo;
  Sel: TRect;
  UpdateRect: TRect;
  DrawRect, ClipRect, IRect: TRect;
  PointsList: PIntArray;
  StrokeList: PIntArray;
  MaxStroke: Integer;
  FrameFlags1, FrameFlags2: DWORD;
  MaxHorzExtent, MaxVertExtent: Integer;
  MaxHorzCell, MaxVertCell: Integer;
  MinHorzCell, MinVertCell: Integer;

  procedure _DrawLines(DoHorz, DoVert: Boolean; StartCol, StartRow, EndCol, EndRow: Longint;
    const CellBounds: array of Integer; OnColor, OffColor: TColor);
  const
    FlatPenStyle = PS_Geometric or PS_Solid or PS_EndCap_Flat or PS_Join_Miter;

    procedure DrawAxisLines(const AxisInfo: TRMGridAxisDrawInfo;
      MajorIndex: Integer; UseOnColor: Boolean);
    var
      LogBrush: TLOGBRUSH;
      Cell, Index: Integer;
      Points: PIntArray;
      StartMajor, StopMajor, StartMinor, StopMinor: Integer;
      MayHaveMerge: Boolean;
      TopIndex: Integer;
      MergePoint: TPoint;

      function FindHorzMerge(ARow, StartIndex: Integer): TPoint;
      var
        I: Integer;
        liCell: TRMCellInfo;
      begin
        Result.x := -1;
        Result.y := -1;
        for i := StartIndex to EndCol do
        begin
          liCell := Cells[i, ARow];
          if CellInMerge(i, ARow) and (ARow <> liCell.EndRow) then
          begin
            Result.x := liCell.StartCol;
            Result.y := liCell.EndCol;
            Exit;
          end;
        end;
      end;

      function FindVertMerge(ACol, StartIndex: Integer): TPoint;
      var
        i: Integer;
        liCell: TRMCellInfo;
      begin
        Result.x := -1;
        Result.y := -1;
        for i := StartIndex to EndRow do
        begin
          liCell := Cells[ACol, i];
          if CellInMerge(ACol, i) and (ACol <> liCell.EndCol) then
          begin
            Result.x := liCell.StartRow;
            Result.y := liCell.EndRow;
            Exit;
          end;
        end;
      end;

    begin
      with Canvas, AxisInfo do
      begin
        Pen.Style := psSolid;
        Pen.Mode := pmCopy;
        if EffectiveLineWidth <> 0 then
        begin
          Pen.Width := FGridLineWidth;
          if UseOnColor then
            Pen.Color := OnColor
          else
            Pen.Color := OffColor;
          if Pen.Width > 1 then
          begin
            LogBrush.lbStyle := BS_Solid;
            LogBrush.lbColor := Pen.Color;
            LogBrush.lbHatch := 0;
            Pen.Handle := ExtCreatePen(FlatPenStyle, Pen.Width, LogBrush, 0, nil);
          end;
          if MajorIndex = 0 then
            Cell := StartCol // 画竖线
          else
            Cell := StartRow; // 画横线
          // 第一根线的位置
          StartMajor := CellBounds[MajorIndex] + EffectiveLineWidth shr 1 +
            GetExtent(Cell);
          // 最后一根线的位置
          StopMajor := CellBounds[2 + MajorIndex] + EffectiveLineWidth;
          // 画线起点
          StartMinor := CellBounds[MajorIndex xor 1];
          // 画线终点
          StopMinor := CellBounds[2 + (MajorIndex xor 1)];
          MayHaveMerge := False;
          // 计算是否可能存在合并区域
          if ((StartMinor > 0) and (StartMajor > 0) or
            (StartMinor > 0) and (StartMajor > 0)) then
            MayHaveMerge := True;
          Points := PointsList;
          Index := 0;
          repeat
            if ((MajorIndex = 0) and (ColWidths[Cell] >= 0)) or
              ((MajorIndex = 1) and (RowHeights[Cell] >= 0)) then
            begin
              // 画线起点
              Points^[Index + MajorIndex] := StartMajor; // MoveTo
              Points^[Index + (MajorIndex xor 1)] := StartMinor;
              Inc(Index, 2);
              // 如果可能存在合并区域
              if MayHaveMerge then
              begin
                if MajorIndex = 0 then // 画竖线
                begin
                  TopIndex := StartRow;
                  while TopIndex <= EndRow do
                  begin
                    MergePoint := FindVertMerge(Cell, TopIndex);
                    if MergePoint.x > 0 then //Have Merge
                    begin
                      Points^[Index + MajorIndex] := StartMajor; // LineTo
                      Points^[Index + (MajorIndex xor 1)] := CellRect(Cell, MergePoint.x).Top;
                      Inc(Index, 2);
                      Points^[Index + MajorIndex] := StartMajor; // MoveTo
                      Points^[Index + (MajorIndex xor 1)] := CellRect(Cell, MergePoint.y).Bottom;
                      Inc(Index, 2);
                      TopIndex := MergePoint.y + 1;
                    end
                    else
                      Inc(TopIndex);
                  end;
                end
                else // 画横线
                begin
                  TopIndex := StartCol;
                  while TopIndex <= EndCol do
                  begin
                    MergePoint := FindHorzMerge(Cell, TopIndex);
                    if MergePoint.x > 0 then
                    begin
                      Points^[Index + MajorIndex] := StartMajor; // LineTo
                      Points^[Index + (MajorIndex xor 1)] := CellRect(MergePoint.x, Cell).Left;
                      Inc(Index, 2);
                      Points^[Index + MajorIndex] := StartMajor; // MoveTo
                      Points^[Index + (MajorIndex xor 1)] := CellRect(MergePoint.y, Cell).Right;
                      Inc(Index, 2);
                      TopIndex := MergePoint.y + 1;
                    end
                    else
                      Inc(TopIndex);
                  end;
                end;
              end;
              // 画线终点
              Points^[I