自定义绘图无效的指针操作+运行时错误

Question

我正在开发一个简单的小应用程序，它有1个图像和3个计时器。目标是在每个球之后绘制一些来回追逐的球。它看起来像这样：

现在的问题是当我关闭应用程序时，我按此顺序得到了一些错误，并且没有在代码中给我一个断点。只有当它从右向左移动时才会发生，而不是从左向右移动。我认为它可能与应用程序关闭后继续执行的计时器有关，因此我在OnClose事件中禁用了计时器 - 但仍然没有运气。

这是DFM代码：

object Form1: TForm1
  Left = 379
  Top = 631
  Width = 696
  Height = 254
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Img: TImage
    Left = 16
    Top = 56
    Width = 649
    Height = 15
  end
  object tmrDraw: TTimer
    Enabled = False
    Interval = 50
    OnTimer = tmrDrawTimer
    Left = 88
    Top = 128
  end
  object tmrBalls: TTimer
    Enabled = False
    Interval = 50
    OnTimer = tmrBallsTimer
    Left = 128
    Top = 128
  end
  object tmrChase: TTimer
    Enabled = False
    Interval = 60
    OnTimer = tmrChaseTimer
    Left = 168
    Top = 128
  end
end

这是源代码：

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Math;

type
  TBallStates = array of Integer;

  TForm1 = class(TForm)
    Img: TImage;
    tmrDraw: TTimer;
    tmrBalls: TTimer;
    tmrChase: TTimer;
    procedure tmrDrawTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure tmrBallsTimer(Sender: TObject);
    procedure tmrChaseTimer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    fPos: Integer;
    fDir: Integer;
    fBalls: TBallStates;
    fBallCount: Integer;
    fBMin: Integer;
    fBMax: Integer;
    fBStep: Integer;
    fCMin: TColor;
    fCMax: TColor;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function ColorBetween(const ColorA, ColorB: TColor; const Percent: Single): TColor;
var
  R1, G1, B1: Byte;
  R2, G2, B2: Byte;
begin
  R1:= GetRValue(ColorA);
  G1:= GetGValue(ColorA);
  B1:= GetBValue(ColorA);
  R2:= GetRValue(ColorB);
  G2:= GetGValue(ColorB);
  B2:= GetBValue(ColorB);
  Result:= RGB(
    EnsureRange(Round(R1*Percent + R2*(100-Percent) / 100), 0, 255),
    EnsureRange(Round(G1*Percent + G2*(100-Percent) / 100), 0, 255),
    EnsureRange(Round(B1*Percent + B2*(100-Percent) / 100), 0, 255)
  );
end;

//This timer sets the intensities of the balls
procedure TForm1.tmrBallsTimer(Sender: TObject);
var
  X: Integer;   //Loop counter
  C: Integer;   //Count of balls
  V: Integer;   //Value of individual ball intensity
begin
  C:= Length(fBalls);
  for X:= 0 to C - 1 do begin
    V:= fBalls[X];    
    if (V >= fBMin - fBStep - 1) and (V <= fBMin + fBStep + 1) then begin
      V:= fBMin;
    end else
    if V > fBMin then begin
      V:= V - fBStep;
    end else
    if V < fBMin then begin
      V:= V + fBStep;
    end;
    fBalls[X]:= V;
  end;
end;

//This timer draws the balls
procedure TForm1.tmrDrawTimer(Sender: TObject);
var
  X: Integer;   //Loop counter
  V: Integer;   //Value of individual ball intensity
  C: Integer;   //Count of balls
  R: TRect;     //Rect of individual ball
  Z: Integer;   //Size of each ball
  Col: TColor;  //Color to draw each ball
  B: TBitmap;
begin
  B:= TBitmap.Create;
  try
    B.Width:= Img.ClientWidth;
    B.Height:= Img.ClientHeight;
    C:= Length(fBalls);
    Z:= Img.Height;
    R:= Rect(0, 0, Z, Z);
    B.TransparentColor:= clWhite;
    B.Transparent:= True;
    B.Canvas.Brush.Style:= bsSolid;
    B.Canvas.Pen.Style:= psClear;
    B.Canvas.Brush.Color:= clWhite;
    B.Canvas.FillRect(B.Canvas.ClipRect);
    for X:= 0 to C - 1 do begin
      V:= fBalls[X];
      Col:= ColorBetween(fCMin, fCMax, (V / fBMax)*100);
      B.Canvas.Brush.Color:= Col;
      B.Canvas.Ellipse(R);
      R.Left:= R.Left + Z;
      R.Right:= R.Right + Z;
    end;
    Img.Picture.Assign(B);
  finally
    B.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  X: Integer;
begin
  fDir:= 1;
  fPos:= 0;
  fBMin:= 0;
  fBMax:= 100;
  fBallCount:= 40;
  fBStep:= 8;
  fCMin:= clNavy;
  fCMax:= clSkyBlue;
  SetLength(fBalls, fBallCount);
  for X:= 0 to Length(fBalls) - 1 do
    fBalls[X]:= fBMin;
  tmrDraw.Enabled:= True;
  tmrBalls.Enabled:= True;
  tmrChase.Enabled:= True;
end;

procedure TForm1.tmrChaseTimer(Sender: TObject);
begin
  fPos:= fPos + fDir;
  if (fPos >= fBallCount) then begin
    fDir:= -1;
  end;
  if (fPos <= 0) then begin
    fDir:= 1;
  end;
  fBalls[fPos]:= fBMax;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  tmrDraw.Enabled:= False;
  tmrBalls.Enabled:= False;
  tmrChase.Enabled:= False;
end;

end.

这是CPU窗口（不知道它是否有帮助），因为首次引发异常：

调用堆栈为空：

编辑：此问题已解决。问题（如下面的答案所示）是写入未分配的数组的索引（我在- 1之后缺少Length(MyArray)）。这是最终产品的图片（两个球在相反方向来回追逐）：

Answer 1

我刚刚在Delphi 6上试过这个，并遇到了同样的问题。经过一些跟踪后，我发现在释放FBalls动态数组时发生了错误，

这个错误发生在旧的Delphi内存管理器中，并且更改为FastMM4解决了它 - 但这有点像黑客。它也可以解释为什么问题不会影响旧版本的Delphi。

即使在表单close中使用SetLength（FBalls，0）也会产生此错误。

编辑 - 根本原因

这让我对数组处理产生了怀疑，然后我注意到tmrChaseTimer中的一个错误，导致它在数组边界外写入。我添加了一些检查，一切正常：

procedure TForm1.tmrChaseTimer(Sender: TObject);
begin
  fPos:= fPos + fDir;
  if (fPos >= fBallCount) then begin
    fDir:= -1;
  end;
  if (fPos <= 0) then begin
    fDir:= 1;
  end;
  if (fPos >= 0) and (fPos < fBallCount) then // <-- prevent writing outside array bounds
    fBalls[fPos]:= fBMax;
end;

我在启用范围检查时修复了代码，并立即抛出错误：

---

调试器异常通知

项目Project1.exe引发异常类ERangeError，并显示消息“范围检查错误”。流程停止了。使用“步骤”或“运行”继续。

确定帮助