Нарисовать линию на image

Необходимо нарисовать линию с определенной толщиной на Timage...как на скринеДелал так :
Кликните здесь для просмотра всего текста
var
  BrState: Boolean;
...
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
BrState:=true;
end;
...
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
if BrState=true then begin
Image1.Canvas.Brush.Color:= clRed;
Image1.Canvas.Brush.Style:= bsSolid;
Image1.Canvas.Pen.Mode:=  pmNotXor;
Image1.Canvas.Pen.Style:= psClear;
Image1.Canvas.Ellipse(x-10,y-10,x+10,y+10);
end;
end;
Но получилось вот это: Буду благодарен за помощь
8 ответов

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ssLeft in Shift then
    Image1.Canvas.Ellipse(x-10,y-10,x+10,y+10);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Canvas.Brush.Color:= clRed;
  Image1.Canvas.Pen.Color := Image1.Canvas.Brush.Color;
end;


Зачем эллипсы? Задайте нужную толщину пера и используйте moveto, lineto.


Зачем эллипсы? Задайте нужную толщину пера и используйте moveto, lineto.
Это потребует дополнительных заморочек с координатами.


procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ssLeft in Shift then
    Image1.Canvas.Ellipse(x-10,y-10,x+10,y+10);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Canvas.Brush.Color:= clRed;
  Image1.Canvas.Pen.Color := Image1.Canvas.Brush.Color;
end;
Вот что получается:Ай нет, забыл удалить часть кода, спасибо большое!))


А можно ли сделать эту линию полупрозрачной? Допустим мне нужно выделить определенную часть картинки желтым полупрозрачным цветом...как желтым маркером в конспектах


А можно ли сделать эту линию полупрозрачной?
Так просто, думаю, не получится. Можно рисовать ее на отдельном Битмапе и накладывать на основное изображение.


Так просто, думаю, не получится. Можно рисовать ее на отдельном Битмапе и накладывать на основное изображение.
Я уже пробовал...линии перекрывают весь текст на 1 битмапе...возможно можно по матрице пробегаться и увеличивать каналы R и G, что б цвет стал более желтым...но думаю это гиблое дело..


думаю это гиблое дело..
Гиблое, т.к. маркер будет становиться частью изображения и накладываться при повторном проходе. Можно сделать так:
Кликните здесь для просмотра всего текста
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
  Bmp1, Bmp2, Bmp3: TBitmap;
  Blend           : TBlendFunction;
 
implementation
 
{$R *.dfm}
 
// ÔóГ*êöèÿ Г*Г*ëîæåГ*ГЁГї îäГ*îãî èçîáðГ*æåГ*ГЁГї Г*Г* äðóãîå Г± Г§Г*Г¤Г*Г*Г*îé ïðîçðГ*Г·Г*îñòüþ
function AlphaTransparent(Bmp1, Bmp2: TBitMap; Alpha: Byte): Boolean;
begin
  Blend.SourceConstantAlpha := Alpha; // ïðîçðГ*Г·Г*îñòü (0..255)
  Result := Windows.AlphaBlend(Bmp1.Canvas.Handle, 0, 0, Bmp2.Width, Bmp2.Height,
                               Bmp2.Canvas.Handle, 0, 0, Bmp2.Width, Bmp2.Height, Blend);
end; {function AlphaTransparent}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Blend.BlendOp     := AC_SRC_OVER;             // $00
  Blend.BlendFlags  := AC_SRC_NO_PREMULT_ALPHA; // $01
  Blend.AlphaFormat := AC_SRC_OVER;             // $00
 
  Bmp1 := TBitmap.Create;
  Bmp2 := TBitmap.Create;
  Bmp3 := TBitmap.Create;
 
  Bmp1.Assign(Image1.Picture.Bitmap);
  Bmp2.Assign(Image1.Picture.Bitmap);
 
  with Bmp2.Canvas.Pen do
  begin
    Color := clYellow;
    Width := 24;
  end;
 
  ************** := True;
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Bmp1.Free;
  Bmp2.Free;
  Bmp3.Free;
end;
 
procedure TForm1.FormPaint(Sender: TObject);
begin
  Bmp3.Assign(Bmp1);
  AlphaTransparent(Bmp3, Bmp2, 75);
  Image1.Picture.Assign(Bmp3);
end;
 
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button <> mbLeft then Exit;
 
  Bmp2.Canvas.MoveTo(X, Y);
  Image1MouseMove(Sender, Shift, X, Y);
end;
 
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not (ssLeft in Shift) then Exit;
 
  Bmp2.Canvas.LineTo(X, Y);
  Repaint;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Bmp2.Assign(Bmp1);
end;
 
end.