delphi - 在Delphi的TImage控件上绘制Sphere

Question

我想这样绘制球体:

下面的代码是生成圆的顶点并在TIMAGE BUT上绘制一个圆，但我希望它用于SPHERE:

for i := 0 to 360 do begin 
   //Find value of X and Y 
   pntCordXY.X := Radius * Cos(DegToRad(i)); 
   pntCordXY.Y := Radius * Sin(DegToRad(i)); 
   if i = 0 then 
      image1.Canvas.MoveTo(Round(pntCordXY.X), Round(pntCordXY.Y)) 
   else 
      image1.Canvas.LineTo(Round(pntCordXY.X), Round(pntCordXY.Y)); 
end;

Answer 1

原来这是一个有趣的练习。好问题!

首先，您专门要求在TImage上绘制这样的球体，但是该组件应该用于显示图形。当然，它具有可以在其上绘制的 Canvas ，但是下面我使用TPaintBox，它是自己绘画的首选组件。因为，您将必须自己绘画。完全。

所需成分:

一些数学运算，用于计算球体上的3D点，绕多个轴旋转地球以及可能将3D点转换为2D屏幕坐标系。基础知识是:

type
  TPoint3D = record
    X: Double;
    Y: Double;
    Z: Double;
  end;

function Sphere(Phi, Lambda: Double): TPoint3D;
begin
  Result.X := Cos(Phi) * Sin(Lambda);
  Result.Y := Sin(Phi);
  Result.Z := Cos(Phi) * Cos(Lambda);
end;

function RotateAroundX(const P: TPoint3D; Alfa: Double): TPoint3D;
begin
  Result.X := P.X;
  Result.Y := P.Y * Cos(Alfa) + P.Z * Sin(Alfa);
  Result.Z := P.Y * -Sin(Alfa) + P.Z * Cos(Alfa);
end;

function RotateAroundY(const P: TPoint3D; Beta: Double): TPoint3D;
begin
  Result.X := P.X * Cos(Beta) + P.Z * Sin(Beta);
  Result.Y := P.Y;
  Result.Z := P.X * -Sin(Beta) + P.Z * Cos(Beta);
end;

一些地球变量可以使用:

var
  Alfa: Integer;   //Rotation around X axis
  Beta: Integer;   //Rotation around Y axis
  C: TPoint;       //Center
  R: Integer;      //Radius
  Phi: Integer;    //Angle relative to XY plane
  Lambda: Integer; //Angle around Z axis (from pole to pole)
  P: TPoint3D;     //2D projection of a 3D point on the sphere's surface

代码以计算纬度圆的所有点:

for Phi := -8 to 8 do
  for Lambda := 0 to 360 do
  begin
    P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
    P := RotateAroundX(P, Alfa);
    P := RotateAroundY(P, Beta);
  end;

代码以计算经度的所有点:

for Lambda := 0 to 17 do
  for Phi := 0 to 360 do
  begin
    P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
    P := RotateAroundX(P, Alfa);
    P := RotateAroundY(P, Beta);
  end;

这些点可用于在油漆盒上绘制线或曲线。这些点的Z值不用于绘制，但有助于确定该点是位于地球的背面还是正面。

逻辑和辅助工具。在绘制地球前面的所有点，线或曲线之前，必须先绘制地球后面的点或线，以保留深度。

一个图形框架或图形库。默认情况下，Delphi装有标准的Windows GDI，可通过绘画框的Canvas属性获得。另一种可能性是GDI +，它更先进并且效率更高。尤其要考虑抗锯齿。这是我使用过的两个框架，但也有其他框架。例如:OpenGL，它将自动将3D对象转换为2D，并能够添加3D曲面，灯光， Material ，着色器和许多其他功能。

一个测试应用程序，添加在该问题的底部。

一种双重缓冲技术，使绘画作品无闪烁。我先选择了一个单独的位图对象，然后在绘制框上绘制该位图，然后在上面绘制了所有内容。该演示程序还演示了没有它的性能(例程:GDIMultipleColorsDirect)。

设置:

在窗体上放置一个绘画框，并将其 Align属性设置为 alClient，添加用于仿真的计时器组件，添加 OnCreate， OnDestroy， OnKeyPress和 OnResize的表单事件处理程序，并添加 PaintBox1.OnPaint的事件处理程序。

object Form1: TForm1
  Left = 497
  Top = 394
  Width = 450
  Height = 450
  Caption = 'Sphere'
  Color = clWhite
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnKeyPress = FormKeyPress
  OnResize = FormResize
  PixelsPerInch = 96
  TextHeight = 13
  object PaintBox1: TPaintBox
    Left = 0
    Top = 0
    Width = 434
    Height = 414
    Align = alClient
    OnPaint = PaintBox1Paint
  end
  object Timer1: TTimer
    Interval = 25
    OnTimer = Timer1Timer
    Left = 7
    Top = 7
  end
end

第一次尝试:

使用默认的GDI，我可以画出从每个点到下一个点的线。为了增加深度感(透视)，我给前面的线条增加了宽度。另外，我逐渐让线条的颜色从暗到亮溢出(例程: GDIMultipleColors)。

第二次尝试:

不错，但是所有像素都很难!让我们尝试对自己进行一些消除锯齿的工作；;)此外，我将颜色计数减少为两种:正面深色，背面浅色。为了摆脱所有单独的线段:现在将每个圆和子午线划分为两条折线。我在两者之间使用了第三种颜色来实现抗锯齿效果(例程: GDIThreeColors)。

GDI +助您一臂之力:

这种抗锯齿并不是最吸引人的。为了获得真正平滑的绘画效果，让我们将代码转换为GDI +样式。对于Delphi 2009及更高版本，该库可用 from here。对于较早的Delphi版本，该库可用 from here。

在GDI +中，绘图的工作方式略有不同。创建一个 TGPGraphics对象，并使用其构造函数将其附加到设备上下文。随后，由API转换对对象的绘制操作，并将其输出到目标上下文(在这种情况下为位图)(例程: GDIPlusDualLinewidths)。

能更好吗？

好吧，这已经足够了。但是，这个地球仪是由只有两种不同线宽的折线组成的。让我们在两者之间添加一些。每个圆或子午线上的段数均由 Precision常数(例程: GDIPlusMultipleLinewidths)控制。

样例应用程序:

按一个键可循环显示上述例程。

unit Globe;

interface

uses
  Windows, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, Math,
  GDIPAPI, GDIPOBJ;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure PaintBox1Paint(Sender: TObject);
  private
    FBmp: TBitmap;
    FPen: TGPPen;
    procedure GDIMultipleColorsDirect;
    procedure GDIMultipleColors;
    procedure GDIThreeColors;
    procedure GDIPlusDualLinewidths;
    procedure GDIPlusMultipleLinewidths;
  public
    A: Integer; //Alfa, rotation round X axis
    B: Integer; //Beta, rotation round Y axis
    C: TPoint;  //Center
    R: Integer; //Radius
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  LineColorFore = $00552B00;
  LineColorMiddle = $00AA957F;
  LineColorBack = $00FFDFBF;
  BackColor = clWhite;
  LineWidthFore = 4.5;
  LineWidthBack = 1.5;
  Precision = 10; //Should be even!

type
  TCycle = 0..Precision - 1;

  TPoint3D = record
    X: Double;
    Y: Double;
    Z: Double;
  end;

function Sphere(Phi, Lambda: Double): TPoint3D;
begin
  Result.X := Cos(Phi) * Sin(Lambda);
  Result.Y := Sin(Phi);
  Result.Z := Cos(Phi) * Cos(Lambda);
end;

function RotateAroundX(const P: TPoint3D; Alfa: Double): TPoint3D;
begin
  Result.X := P.X;
  Result.Y := P.Y * Cos(Alfa) + P.Z * Sin(Alfa);
  Result.Z := P.Y * -Sin(Alfa) + P.Z * Cos(Alfa);
end;

function RotateAroundY(const P: TPoint3D; Beta: Double): TPoint3D;
begin
  Result.X := P.X * Cos(Beta) + P.Z * Sin(Beta);
  Result.Y := P.Y;
  Result.Z := P.X * -Sin(Beta) + P.Z * Cos(Beta);
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Brush.Style := bsClear; //This is múch cheaper then DoubleBuffered := True
  FBmp := TBitmap.Create;
  FPen := TGPPen.Create(ColorRefToARGB(ColorToRGB(clBlack)));
  A := 35;
  B := 25;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FPen.Free;
  FBmp.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  C.X := PaintBox1.ClientWidth div 2;
  C.Y := PaintBox1.ClientHeight div 2;
  R := Min(C.X, C.Y) - 10;
  FBmp.Width := PaintBox1.ClientWidth;
  FBmp.Height := PaintBox1.ClientHeight;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  A := A + 2;
  B := B + 1;
  PaintBox1.Invalidate;
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
  Tag := Tag + 1;
  PaintBox1.Invalidate;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  case Tag mod 5 of
    0: GDIMultipleColorsDirect;
    1: GDIMultipleColors;
    2: GDIThreeColors;
    3: GDIPlusDualLinewidths;
    4: GDIPlusMultipleLinewidths;
  end;
end;

procedure TForm1.GDIPlusMultipleLinewidths;
var
  Lines: array of TPointFDynArray;
  PointCount: Integer;
  LineCount: Integer;
  Drawing: TGPGraphics;
  Alfa: Double;
  Beta: Double;
  Cycle: TCycle;
  Phi: Integer;
  Lambda: Integer;
  P: TPoint3D;
  Filter: TCycle;
  PrevFilter: TCycle;
  I: Integer;

  procedure ResetLines;
  begin
    SetLength(Lines, 0);
    LineCount := 0;
    PointCount := 0;
  end;

  procedure FinishLastLine;
  begin
    if PointCount < 2 then
      Dec(LineCount)
    else
      SetLength(Lines[LineCount - 1], PointCount);
  end;

  procedure NewLine;
  begin
    if LineCount > 0 then
      FinishLastLine;
    SetLength(Lines, LineCount + 1);
    SetLength(Lines[LineCount], 361);
    Inc(LineCount);
    PointCount := 0;
  end;

  procedure AddPoint(X, Y: Single);
  begin
    Lines[LineCount - 1][PointCount] := MakePoint(X, Y);
    Inc(PointCount);
  end;

  function CycleFromZ(Z: Single): TCycle;
  begin
    Result := Round((Z + 1) / 2 * High(TCycle));
  end;

  function CycleToLineWidth(ACycle: TCycle): Single;
  begin
    Result := LineWidthBack +
      (LineWidthFore - LineWidthBack) * (ACycle / High(TCycle));
  end;

  function CycleToLineColor(ACycle: TCycle): TGPColor;
  begin
    if ACycle <= (High(TCycle) div 2) then
      Result := ColorRefToARGB(ColorToRGB(LineColorBack))
    else
      Result := ColorRefToARGB(ColorToRGB(LineColorFore));
  end;

begin
  Drawing := TGPGraphics.Create(FBmp.Canvas.Handle);
  try
    Drawing.Clear(ColorRefToARGB(ColorToRGB(clWhite)));
    Drawing.SetSmoothingMode(SmoothingModeAntiAlias);
    Alfa := DegToRad(A);
    Beta := DegToRad(B);
    for Cycle := Low(TCycle) to High(TCycle) do
    begin
      ResetLines;
      //Latitude
      for Phi := -8 to 8 do
      begin
        NewLine;
        PrevFilter := 0;
        for Lambda := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          Filter := CycleFromZ(P.Z);
          if Filter <> PrevFilter then
          begin
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
            NewLine;
          end;
          if Filter = Cycle then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevFilter := Filter;
        end;
      end;
      //Longitude
      for Lambda := 0 to 17 do
      begin
        NewLine;
        PrevFilter := 0;
        for Phi := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          Filter := CycleFromZ(P.Z);
          if Filter <> PrevFilter then
          begin
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
            NewLine;
          end;
          if Filter = Cycle then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevFilter := Filter;
        end;
      end;
      FinishLastLine;
      FPen.SetColor(CycleToLineColor(Cycle));
      FPen.SetWidth(CycleToLineWidth(Cycle));
      for I := 0 to LineCount - 1 do
        Drawing.DrawLines(FPen, PGPPointF(@(Lines[I][0])), Length(Lines[I]));
      if Cycle = (High(TCycle) div 2 + 1) then
        Drawing.DrawEllipse(FPen, C.X - R, C.Y - R, 2 * R, 2 * R);
    end;
  finally
    Drawing.Free;
  end;
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIPlusDualLinewidths;
const
  LineColors: array[Boolean] of TColor = (LineColorFore, LineColorBack);
  LineWidths: array[Boolean] of Single = (LineWidthFore, LineWidthBack);
  BackColor = clWhite;
var
  Lines: array of TPointFDynArray;
  PointCount: Integer;
  LineCount: Integer;
  Drawing: TGPGraphics;
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  BackSide: Boolean;
  P: TPoint3D;
  PrevZ: Double;
  I: Integer;

  procedure ResetLines;
  begin
    SetLength(Lines, 0);
    LineCount := 0;
    PointCount := 0;
  end;

  procedure FinishLastLine;
  begin
    if PointCount < 2 then
      Dec(LineCount)
    else
      SetLength(Lines[LineCount - 1], PointCount);
  end;

  procedure NewLine;
  begin
    if LineCount > 0 then
      FinishLastLine;
    SetLength(Lines, LineCount + 1);
    SetLength(Lines[LineCount], 361);
    Inc(LineCount);
    PointCount := 0;
  end;

  procedure AddPoint(X, Y: Single);
  begin
    Lines[LineCount - 1][PointCount] := MakePoint(X, Y);
    Inc(PointCount);
  end;

begin
  Drawing := TGPGraphics.Create(FBmp.Canvas.Handle);
  try
    Drawing.Clear(ColorRefToARGB(ColorToRGB(clWhite)));
    Drawing.SetSmoothingMode(SmoothingModeAntiAlias);
    Alfa := DegToRad(A);
    Beta := DegToRad(B);
    for BackSide := True downto False do
    begin
      ResetLines;
      //Latitude
      for Phi := -8 to 8 do
      begin
        NewLine;
        PrevZ := 0;
        for Lambda := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          if Sign(P.Z) <> Sign(PrevZ) then
            NewLine;
          if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevZ := P.Z;
        end;
      end;
      //Longitude
      for Lambda := 0 to 17 do
      begin
        NewLine;
        PrevZ := 0;
        for Phi := 0 to 360 do
        begin
          P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
          P := RotateAroundX(P, Alfa);
          P := RotateAroundY(P, Beta);
          if Sign(P.Z) <> Sign(PrevZ) then
            NewLine;
          if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
            AddPoint(C.X + P.X * R, C.Y + P.Y * R);
          PrevZ := P.Z;
        end;
      end;
      FinishLastLine;
      FPen.SetColor(ColorRefToARGB(ColorToRGB(LineColors[BackSide])));
      FPen.SetWidth(LineWidths[BackSide]);
      for I := 0 to LineCount - 1 do
        Drawing.DrawLines(FPen, PGPPointF(@(Lines[I][0])), Length(Lines[I]));
    end;
    Drawing.DrawEllipse(FPen, C.X - R, C.Y - R, 2 * R, 2 * R);
  finally
    Drawing.Free;
  end;
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIThreeColors;
const
  LineColors: array[TValueSign] of TColor = (LineColorBack, LineColorMiddle,
    LineColorFore);
  LineWidths: array[TValueSign] of Integer = (2, 4, 2);
var
  Lines: array of array of TPoint;
  PointCount: Integer;
  LineCount: Integer;
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  BackSide: Boolean;
  P: TPoint3D;
  PrevZ: Double;
  I: TValueSign;
  J: Integer;

  procedure ResetLines;
  begin
    SetLength(Lines, 0);
    LineCount := 0;
    PointCount := 0;
  end;

  procedure FinishLastLine;
  begin
    if PointCount < 2 then
      Dec(LineCount)
    else
      SetLength(Lines[LineCount - 1], PointCount);
  end;

  procedure NewLine;
  begin
    if LineCount > 0 then
      FinishLastLine;
    SetLength(Lines, LineCount + 1);
    SetLength(Lines[LineCount], 361);
    Inc(LineCount);
    PointCount := 0;
  end;

  procedure AddPoint(APoint: TPoint); overload;
  var
    Last: TPoint;
  begin
    if PointCount > 0 then
    begin
      Last := Lines[LineCount - 1][PointCount - 1];
      if (APoint.X = Last.X) and (APoint.Y = Last.Y) then
        Exit;
    end;
    Lines[LineCount - 1][PointCount] := APoint;
    Inc(PointCount);
  end;

  procedure AddPoint(X, Y: Integer); overload;
  begin
    AddPoint(Point(X, Y));
  end;

begin
  FBmp.Canvas.Brush.Color := BackColor;
  FBmp.Canvas.FillRect(Rect(0, 0, FBmp.Width, FBmp.Height));
  Alfa := DegToRad(A);
  Beta := DegToRad(B);
  for BackSide := True downto False do
  begin
    ResetLines;
    //Latitude
    for Phi := -8 to 8 do
    begin
      NewLine;
      PrevZ := 0;
      for Lambda := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if Sign(P.Z) <> Sign(PrevZ) then
          NewLine;
        if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
          AddPoint(Round(C.X + P.X * R), Round(C.Y + P.Y * R));
        PrevZ := P.Z;
      end;
    end;
    //Longitude
    for Lambda := 0 to 17 do
    begin
      NewLine;
      PrevZ := 0;
      for Phi := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if Sign(P.Z) <> Sign(PrevZ) then
          NewLine;
        if (BackSide and (P.Z < 0)) or (not BackSide and (P.Z >= 0)) then
          AddPoint(Round(C.X + P.X * R), Round(C.Y + P.Y * R));
        PrevZ := P.Z;
      end;
    end;
    FinishLastLine;
    if BackSide then
    begin
      FBmp.Canvas.Pen.Color := LineColors[-1];
      FBmp.Canvas.Pen.Width := LineWidths[-1];
      for J := 0 to LineCount - 1 do
        FBmp.Canvas.Polyline(Lines[J]);
    end
    else
      for I := 0 to 1 do
      begin
        FBmp.Canvas.Pen.Color := LineColors[I];
        FBmp.Canvas.Pen.Width := LineWidths[I];
        for J := 0 to LineCount - 1 do
          FBmp.Canvas.Polyline(Lines[J])
      end
  end;
  FBmp.Canvas.Brush.Style := bsClear;
  FBmp.Canvas.Ellipse(C.X - R, C.Y - R, C.X + R, C.Y + R);
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIMultipleColors;
var
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  P: TPoint3D;
  Backside: Boolean;

  function ColorFromZ(Z: Single): TColorRef;
  var
    R: Integer;
    G: Integer;
    B: Integer;
  begin
    Z := (Z + 1) / 2;
    R := GetRValue(LineColorFore) - GetRValue(LineColorBack);
    R := GetRValue(LineColorBack) + Round(Z * R);
    G := GetGValue(LineColorFore) - GetGValue(LineColorBack);
    G := GetGValue(LineColorBack) + Round(Z * G);
    B := GetBValue(LineColorFore) - GetBValue(LineColorBack);
    B := GetBValue(LineColorBack) + Round(Z * B);
    Result := RGB(R, G, B);
  end;

begin
  FBmp.Canvas.Pen.Width := 2;
  FBmp.Canvas.Brush.Color := BackColor;
  FBmp.Canvas.FillRect(PaintBox1.ClientRect);
  Alfa := DegToRad(A);
  Beta := DegToRad(B);
  for Backside := True downto False do
  begin
    if not BackSide then
      FBmp.Canvas.Pen.Width := 3;
    //Latitude
    for Phi := -8 to 8 do
      for Lambda := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Lambda = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            FBmp.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          FBmp.Canvas.Pen.Color := ColorFromZ(P.Z);
          FBmp.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
    //Longitude
    for Lambda := 0 to 17 do
      for Phi := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Phi = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            FBmp.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          FBmp.Canvas.Pen.Color := ColorFromZ(P.Z);
          FBmp.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
  end;
  PaintBox1.Canvas.Draw(0, 0, FBmp);
end;

procedure TForm1.GDIMultipleColorsDirect;
var
  Alfa: Double;
  Beta: Double;
  Phi: Integer;
  Lambda: Integer;
  P: TPoint3D;
  Backside: Boolean;

  function ColorFromZ(Z: Single): TColorRef;
  var
    R: Integer;
    G: Integer;
    B: Integer;
  begin
    Z := (Z + 1) / 2;
    R := GetRValue(LineColorFore) - GetRValue(LineColorBack);
    R := GetRValue(LineColorBack) + Round(Z * R);
    G := GetGValue(LineColorFore) - GetGValue(LineColorBack);
    G := GetGValue(LineColorBack) + Round(Z * G);
    B := GetBValue(LineColorFore) - GetBValue(LineColorBack);
    B := GetBValue(LineColorBack) + Round(Z * B);
    Result := RGB(R, G, B);
  end;

begin
  PaintBox1.Canvas.Pen.Width := 2;
  PaintBox1.Canvas.Brush.Color := BackColor;
  PaintBox1.Canvas.FillRect(PaintBox1.ClientRect);
  Alfa := DegToRad(A);
  Beta := DegToRad(B);
  for Backside := True downto False do
  begin
    if not BackSide then
      PaintBox1.Canvas.Pen.Width := 3;
    //Latitude
    for Phi := -8 to 8 do
      for Lambda := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi * 10), DegToRad(Lambda));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Lambda = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            PaintBox1.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          PaintBox1.Canvas.Pen.Color := ColorFromZ(P.Z);
          PaintBox1.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
    //Longitude
    for Lambda := 0 to 17 do
      for Phi := 0 to 360 do
      begin
        P := Sphere(DegToRad(Phi), DegToRad(Lambda * 10));
        P := RotateAroundX(P, Alfa);
        P := RotateAroundY(P, Beta);
        if (Phi = 0) or (Backside and (P.Z >= 0)) or
          (not Backside and (P.Z < 0)) then
            PaintBox1.Canvas.MoveTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R))
        else
        begin
          PaintBox1.Canvas.Pen.Color := ColorFromZ(P.Z);
          PaintBox1.Canvas.LineTo(C.X + Round(P.X * R), C.Y + Round(P.Y * R));
        end;
      end;
  end;
end;

end.

(感谢bummi的 comment。)