Ein Bild als Kugel darstellen

[SirThornberry]

Vorab kann ich schon sagen das es nicht so elegant gelöst ist wie in deinem Beispiel da bei mir nur auf der X-Achse gestretcht wird (das auskommentierte wäre die Variante nur auf der Y-Achse zu stretchen). Ich werde wohl versuchen das von dir gepostete so abzuwandeln das "pixels" weg fällt (dazu gibts ja pointer so das nicht ständig nen changed ausgelöst wird).

Den Sourcecode einzeln zu posten ist bissl schwer (da bissl verteilt), deswegen gleich mein ganzes Object als Unit:

Delphi-Quellcode:

unit uKugelPicObj;

interface

uses
  windows, graphics;

type
  TKugelPicObj = class(TObject)
  private
    fPicOrigin: TBitmap;
    fPicStretched: TBitmap;
    fPicTmp      : TBitmap;
    fBallSize    : DWord;
    fRotationX   : Extended;
    fSizes       : Array of DWord;
    procedure FCalcNewSize;
    procedure FOnPicChanged(Sender: TObject);
    procedure FRefreshStretchedPic;
    procedure FRefreshTmpPic;
    procedure FSetPicture(APic: TBitmap);
    procedure FSetRotation(AType: Integer; ARotation: Extended);
    procedure FSetSize(ASize: DWord);
  public
    constructor Create;
    destructor Destroy; override;

    property Picture: TBitmap read fPicOrigin write FSetPicture;
    property RotationX: Extended Index 0 read fRotationX write FSetRotation;
    property Size: DWord read fBallSize write FSetSize;

    function DrawBall(ADst: TBitmap): Boolean;
  end;

implementation

{==============================================================================}

constructor TKugelPicObj.Create;
begin
  inherited Create;
  fBallSize           := 100;
  fPicOrigin          := TBitmap.Create;
  fPicOrigin.OnChange := FOnPicChanged;
  fPicStretched       := TBitmap.Create;
  fPicTmp             := TBitmap.Create;
  fRotationX          := 0;
  FCalcNewSize;
end;

{==============================================================================}

destructor TKugelPicObj.Destroy;
begin
  fPicTmp.Free;
  fPicStretched.Free;
  fPicOrigin.Free;
  inherited Destroy;
end;

{==============================================================================}

function TKugelPicObj.DrawBall(ADst: TBitmap): Boolean;
var LCount,
    LPosition: Integer;
    LSize    : DWord;
begin
  if (fPicOrigin.Width > 0) and (fPicOrigin.Height > 0) then
  begin
    ADst.Width := fBallSize;
    ADst.Height := fBallSize;
    SetStretchBltMode(ADst.Canvas.Handle, STRETCH_HALFTONE);
    SetBrushOrgEx(ADst.Canvas.Handle, 0, 0, nil);

    for LCount := 0 to fBallSize - 1 do
    begin
      LSize := fSizes[LCount];
      LPosition := (fBallSize - LSize) div 2;

      //StretchBlt(ADst.Canvas.Handle, LCount, LPosition, 1, LSize,
      //           fPicTmp.Canvas.Handle, LCount, 0, 1, fPicTmp.Height, SRCCOPY);

      StretchBlt(ADst.Canvas.Handle, LPosition, LCount, LSize, 1,
                 fPicTmp.Canvas.Handle, 0, LCount, fPicTmp.Width, 1, SRCCOPY);
    end;
    result := True;
  end else
    result := False;
end;

{==============================================================================}

procedure TKugelPicObj.FCalcNewSize;
var LCount,
    LHalfBallSize: Integer;
begin
  LHalfBallSize := Trunc(fBallSize / 2);
  SetLength(fSizes, fBallSize);
  for LCount := 0 to fBallSize - 1 do
  begin
    if (LCount > LHalfBallSize) then
      fSizes[LCount] := Round(Sqrt(Sqr(LHalfBallSize) - Sqr(LCount - LHalfBallSize))) * 2
    else
      fSizes[LCount] := Round(Sqrt(Sqr(LHalfBallSize) - Sqr(LHalfBallSize - LCount))) * 2;
  end;
  FRefreshStretchedPic;
end;

{==============================================================================}

procedure TKugelPicObj.FOnPicChanged(Sender: TObject);
begin
  FRefreshStretchedPic;
end;

{==============================================================================}

procedure TKugelPicObj.FRefreshStretchedPic;
begin
  if (fPicOrigin.Width = 0) or (fPicOrigin.Height = 0) then
    fPicStretched.Assign(fPicOrigin)
  else begin
    fPicStretched.Width  := fBallSize;
    fPicStretched.Height := fBallSize;
    SetStretchBltMode(fPicStretched.Canvas.Handle, STRETCH_HALFTONE);
    SetBrushOrgEx(fPicStretched.Canvas.Handle, 0, 0, nil);
    StretchBlt(fPicStretched.Canvas.Handle, 0, 0, fBallSize, fBallSize,
               fPicOrigin.Canvas.Handle, 0, 0, fPicOrigin.Width, fPicOrigin.Height, SRCCOPY);
  end;
  FRefreshTmpPic;
end;

{==============================================================================}

procedure TKugelPicObj.FRefreshTmpPic;
var LLeft: Integer;
begin
  if (fPicStretched.Width > 0) and (fPicStretched.Height > 0) then
  begin
    fPicTmp.Width  := fPicStretched.Width;
    fPicTmp.Height := fPicStretched.Height;

    LLeft := Round((fPicTmp.Width) / 360 * fRotationX);

    BitBlt(fPicTmp.Canvas.Handle, 0, 0, fPicTmp.Width - LLeft, fPicTmp.Height,
           fPicStretched.Canvas.Handle, LLeft, 0, SRCCOPY);

    BitBlt(fPicTmp.Canvas.Handle, fPicTmp.Width - LLeft, 0, fPicTmp.Width, fPicTmp.Height,
           fPicStretched.Canvas.Handle, 0, 0, SRCCOPY);
  end;
end;

{==============================================================================}

procedure TKugelPicObj.FSetPicture(APic: TBitmap);
begin
  if (APic <> fPicOrigin) then
  begin
    if (APic = nil) then
    begin
      fPicOrigin.Width  := 0;
      fPicOrigin.Height := 0;
    end else
      fPicOrigin.Assign(APic);
  end;
end;

{==============================================================================}

procedure TKugelPicObj.FSetRotation(AType: Integer; ARotation: Extended);
  procedure LSetVal(var ACurrVal: Extended);
  begin
    if ARotation <> ACurrVal then
    begin
      while (ARotation >= 360) do
        ARotation := ARotation - 360;
      while (ARotation < 0) do
        ARotation := ARotation + 360;
      ACurrVal := ARotation;
      FRefreshTmpPic;
    end;
  end;
begin
  case AType of
    0: LSetVal(fRotationX);
  end;
end;

{==============================================================================}

procedure TKugelPicObj.FSetSize(ASize: DWord);
begin
  if ASize < 1 then
    ASize := 1;
  if ASize <> fBallSize then
  begin
    fBallSize := ASize;
    FCalcNewSize;
  end;
end;

{==============================================================================}

end.

Das mit den jucken in den Fingern kenn ich. Denn das ganze mit dem Kugel brauch ich nicht wirklich, bin nur auf die Idee gekommen als ich gestern das Sterne-Projekt gesehen hab und dann den Screensaver von Galileo wo auch planeten ihre Bahnen ziehen). War also nen reines fingerjuck-projekt