Рисование на Image.

[zvygin1964]

Хочу рисованную стрелку. Сам сделать не смогу. Пока делаю так:

procedure TForm1.Timer1Timer(Sender: TObject);
begin
     t:=t+i ;
     x:=round(xc+ro*sin(t*pi/180))-((random(20)*i));{определяем координаты}
     y:=round(yc-ro*cos(t*pi/180));
      //======================
      if   (x<=40) then   // условие границы
      begin
     x:=40 ;
     i:=1;
      end
      else
      begin
    //ничего не делаем
     end;

      if (x>=290) then   // условие границы
      begin
      x:=290;
      i:=-1;
      end
     else
     begin
     //ничего не делаем
     end;
    // ======================
     Shape1.Left:=x;
     Shape1.Top:=y;
end;

[newerow1989]

Ну, тут 2 варианта:
- либо добавить Image2, нарисовать на нем стрелку и поворачивать ее;
- либо геометрически вычислять расположение контура стрелки

Я могу отрезок начертить без стрелки!

Я не могу сообразить, для чего "-((random(20)*i));"?

[zvygin1964]

Сообщение от newerow1989

- либо добавить Image2, нарисовать на нем стрелку и поворачивать ее;

С этим я справиться не смог. Не слушается и не переводится в Лазарус:

type
  PixelArray=array [0..32768] of TRGBTriple;
  pPixelArray=^PixelArray;
 
var
  b: TBitmap;

procedure RotateBitmap_ads(SourceBitmap: TBitmap;
          out DestBitmap: TBitmap; Center: TPoint; Angle: Double);
var
  cosRadians : Double;
  inX : Integer;
  inXOriginal : Integer;
  inXPrime : Integer;
  inXPrimeRotated : Integer;
  inY : Integer;
  inYOriginal : Integer;
  inYPrime : Integer;
  inYPrimeRotated : Integer;
  OriginalRow : pPixelArray;
  Radians : Double;
  RotatedRow : pPixelArray;
  sinRadians : Double;
begin
  DestBitmap.Width := SourceBitmap.Width;
  DestBitmap.Height := SourceBitmap.Height;
  DestBitmap.PixelFormat := pf24bit;
  Radians := -(Angle) * PI / 180;
  sinRadians := Sin(Radians);
  cosRadians := Cos(Radians);
  for inX := DestBitmap.Height-1 downto 0 do
  begin
    RotatedRow := DestBitmap.Scanline[inX];
    inXPrime := 2*(inX - 300) + 1;      //inXPrime := 2*(inX - Center.y) + 1;
    for inY := DestBitmap.Width-1 downto 0 do
    begin
     inYPrime := 2*(inY - Center.x) + 1;    // inYPrime := 2*(inY - Center.x) + 1;   // inYPrime := 2*(inY - 300) + 1;    // inYPrime := 2*(inY - Center.x) + 1;
      inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians); //inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians);
      inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians);
      inYOriginal := (inYPrimeRotated - 1)+ 200;   // inYOriginal := (inYPrimeRotated - 1) div 2 + Center.x;
      inXOriginal := (inXPrimeRotated - 1) + 200; //inXOriginal := (inXPrimeRotated - 1) div 2 + 200;
      if (inYOriginal >= 0) and (inYOriginal <= SourceBitmap.Width-1) and
      (inXOriginal >= 0) and (inXOriginal <= SourceBitmap.Height-1) then
      begin
        OriginalRow := SourceBitmap.Scanline[inXOriginal];
        RotatedRow[inY] := OriginalRow[inYOriginal];
      end
      else
      begin
        RotatedRow[inY].rgbtBlue :=255; //  фон под картинкой после поворота   := 255;
        RotatedRow[inY].rgbtGreen :=255;
        RotatedRow[inY].rgbtRed :=255;//clWhite ;
      end;
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  b:= TBitmap.Create;
  b.Width:= Image3.Width;
  b.Height:= Image3.Height;
  Image3.Transparent:=True;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  b.Free;
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  RotateBitmap_ads(Image1.Picture.Bitmap,b,Point(Image1.Width div 2,Image1.Height div 2),TrackBar1.Position);
  Image3.Canvas.Draw(0,0,b);
end;

Сообщение от newerow1989

для чего "-((random(20)*i));"?

Изображение становится реалистичней.

[zvygin1964]

Сообщение от newerow1989

отрезок начертить без стрелки

Если Canvas, то получается непрозрачным.

[newerow1989]

Прозрачность:

Image1.Transparent:=true;

либо в окне объекте инспектора установить

[zvygin1964]

Сообщение от newerow1989

Прозрачность:

Image1.Transparent:=true;

либо в окне объекте инспектора установить

Transparent:=true;// Не помогает.

Переделать на Лазарус не смог:

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
  Image1.Swivel := TrackBar1.Position;
end;

{ TImage }

constructor TImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  
  FScale := TBitmap.Create;
  FScale.Width := 800;
  FScale.Height := 500;
  SetScale();

  Center := True;
  Stretch := True;
  Proportional := True;

  Swivel := 0;
end;

destructor TImage.Destroy;
begin
  FScale.Free;
  inherited;
end;

//procedure TImage.WMPaint(var Message: TWMPaint);
procedure TImage.Paint;
const
{$J+}
  b: Boolean = True;
{$J-}
var
  Xo, Yo, R: Integer;
  A: Real;
begin
  inherited;

  b := not b;
  if {Proportional and} b then Exit;

  Picture.Assign(FScale);

  Xo := 400;   // Xo := 400;
  Yo := 500;    //  Yo := 400;
  R := 350;
  A := FSwivel * pi / 180;

  with Canvas, Pen do
  begin
    Width := 5;
    Color := clBlack;
    MoveTo(Xo, Yo);
    LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));
  end; 
end;

procedure TImage.SetScale;
var
  i, j,
  Xo, Yo,
  X, Y,
  R,
  A1, A2: Integer;

  A, dA: Real;

  s: String;

begin
  Xo := 0;        //Xo := 400;
  Yo := 400;
  R := 300;
  A1 := 150;
  A2 := -120;
  A := A1 * pi / 180;
  dA := A2 / (4 * 5) * pi / 180;

  with FScale.Canvas, Pen do
  begin

    Brush.Style := bsClear;
    Brush.Color := clMoneyGreen;
    Font.Size := 16;


    Width := 5;
    Color := clWhite;
    MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
    AngleArc(FScale.Canvas.Handle, Xo, Yo, R, A1, A2);

    MoveTo(Xo + Round(R * cos(A)), Yo - Round(R * sin(A)));
    LineTo(Xo + Round((R + 35) * cos(A)), Yo - Round((R + 35) * sin(A)));

  end;
end;

procedure TImage.SetSwivel(ASwivel: Integer);
begin
  FSwivel := 150 - ASwivel;
  Repaint;
end;

[newerow1989]

А если индекс поменять:
Image3

Вложения не полностью выложены в первом посте!

[zvygin1964]

Сообщение от newerow1989

Вложения не полностью выложены в первом посте!

Переложил сюда: https://www.dropbox.com/sh/rhlrnu089...RH_MZ9XAa?dl=0


Это Панел не просвечивается. Нет у неё свойства Transparent .

[newerow1989]

Вот поворачивание стрелки на Image:

var p:array of array of TColor;
    x0,y0,alfa:integer;

procedure TForm1.FormCreate(Sender: TObject);
var i,j:integer;
begin
   alfa:=0;
   x0:=Image1.Width div 2;
   y0:=Image1.Height div 2;
   If x0<y0 then
      x0:=y0;
   If x0>y0 then
      y0:=x0;
   SetLength(p,x0*2,y0*2);
   With Image1.Canvas do
   begin
      Pen.Color:=clBlack;
      Brush.Color:=clBlue;
      Polygon([Point(x0-5,y0),Point(x0-5,15),Point(x0-10,20),Point(x0,0),
         Point(x0+10,20),Point(x0+5,15),Point(x0+5,y0)]);
      For i:=0 to x0*2-1 do
         For j:=0 to y0*2-1 do
            p[i,j]:=Pixels[i,j];
   end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var i,j,x,y:integer;
    al,l:real;
begin
   alfa:=alfa+1;
   With Image1.Canvas do
   begin
      Pen.Color:=clWhite;
      Brush.Color:=clWhite;
      Rectangle(0,0,Image1.Width,Image1.Height);
      For i:=0 to Image1.Width do
         For j:=0 to Image1.Height do
         begin
            x:=-x0+i;
            y:=y0-j;
            l:=Sqrt(x*x+y*y);
            If x=0 then
            begin
               If y>0 then
                  al:=90 else
               If y<0 then
                  al:=270 else
                  al:=0;
            end else
            begin
               al:=ArcTan(y/x)*180/pi;
               If x<0 then
                  al:=al+180;
            end;
            al:=al+alfa+180;
            x:=Round(Cos(al*pi/180)*l)+x0;
            y:=Round(Sin(al*pi/180)*l)+y0;
            If (x>=0) and (y>=0) and (x<x0*2) and (y<y0*2) then
               Pixels[i,j]:=p[x,y];
         end;
   end;
end;

[zvygin1964]

Нет. Тоже получилась не прозрачная. Да ещё и на черном фоне.