DUzun's Web
Programare, proiecte personale, divertisment

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, ExtCtrls, StdCtrls, ActnMan, ActnColorMaps, Buttons, Menus, Jpeg,

  ComCtrls,

  ManJul, UGraph;

​

type

  TForm1 = class(TForm)

    Panel1: TPanel;

    Image1: TImage;

    MainMenu1: TMainMenu;

    File1: TMenuItem;

    Open1: TMenuItem;

    Save1: TMenuItem;

    New1: TMenuItem;

    Close1: TMenuItem;

    Panel2: TPanel;

    ColorBox1: TColorBox;

    Label1: TLabel;

    ScrollBar1: TScrollBar;

    Label2: TLabel;

    Edit1: TMenuItem;

    Fill1: TMenuItem;

    Mandelbrot1: TMenuItem;

    Attrib1: TMenuItem;

    xor1: TMenuItem;

    or1: TMenuItem;

    and1: TMenuItem;

    Intensity1: TMenuItem;

    Invert1: TMenuItem;

    RadioButton1: TRadioButton;

    RadioButton2: TRadioButton;

    Pen1: TMenuItem;

    procedure FormCreate(Sender: TObject);

    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,

      Y: Integer);

    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;

      Shift: TShiftState; X, Y: Integer);

    procedure ScrollBar1Change(Sender: TObject);

    procedure Save1Click(Sender: TObject);

    procedure Open1Click(Sender: TObject);

    procedure New1Click(Sender: TObject);

    procedure Close1Click(Sender: TObject);

    procedure Fill1Click(Sender: TObject);

    procedure Img1Resize(Sender: TObject);

    procedure Negative1Click(Sender: TObject);

    procedure Attrib1Click(Sender: TObject);

    procedure xor1Click(Sender: TObject);

    procedure or1Click(Sender: TObject);

    procedure and1Click(Sender: TObject);

    procedure Intensity1Click(Sender: TObject);

    procedure Pen1Click(Sender: TObject);

  private

    lX, lY, lP: integer;

    Drowing: Boolean;

  end;

​

var

  Form1: TForm1;

​

implementation

{$R *.dfm}

​

procedure TForm1.FormCreate(Sender: TObject);

begin

   Top  := ( Screen.Width  - Width  ) div 2;

   Left := ( Screen.Height - Height ) div 2;

   Drowing := false;

   Image1.Picture.Create;

   New1Click(Sender);

end;

​

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,

  Y: Integer);

begin

 if Pen1.Checked and Drowing then with Image1.Canvas do begin

   MoveTo(lX, lY);

   LineTo(X, Y);

 end;

 lX := X; lY := Y;

 Image1.Hint := IntToStr(X)+':'+IntToStr(Y);

end;

​

procedure TForm1.Image1MouseUp;

begin

   Drowing := false;

end;

​

procedure TForm1.Image1MouseDown;

begin

  lX := X; lY := Y;

  with Image1.Canvas do begin

    Pen.Color := ColorBox1.Selected;

    Pen.Width := ScrollBar1.Position;

  end;

  Drowing := true;

  Image1MouseMove(Sender, Shift, X, Y);

end;

​

procedure TForm1.Img1Resize(Sender: TObject);

begin

   with Image1 do begin

     Width  := Panel1.Width;

     Height := Panel1.Height;

     if (Picture.Bitmap=nil) then with Picture do begin

        Bitmap := TBitmap.Create;

        Bitmap.PixelFormat := pf32bit;

     end;

     Picture.Bitmap.Canvas.Brush.Color := ColorBox1.Selected;

     Picture.Bitmap.Width := Width;

     Picture.Bitmap.Height:= Height;

   end;

end;

​

procedure TForm1.ScrollBar1Change(Sender: TObject);

begin with ScrollBar1 do Hint := IntToStr(Position); end;

​

procedure TForm1.New1Click(Sender: TObject);

begin

   Img1Resize(Sender);

   with Image1.Picture.Bitmap.Canvas do begin

     Brush.Color := clCream;

     FillRect(Rect(0,0,Width, Height));

   end;

end;

​

procedure TForm1.Open1Click(Sender: TObject);

Var FN: String;

    j: TJPEGImage;

begin

  if PromptForFileName(FN, 'All suported|*.bmp;*.jpg|Bitmap|*.bmp|JPEG|*.jpg|') then begin

     if UpperCase(ExtractFileExt(FN)) = '.JPG' then begin

       j := TJPEGImage.Create;

       j.LoadFromFile(FN);

       Image1.Picture.Bitmap.Assign(j);

       j.Free;

     end else

       Image1.Picture.Bitmap.LoadFromFile(FN);

       Width  := Image1.Width + Panel2.Width;

       Height := Image1.Height;

  end;

end;

​

procedure TForm1.Save1Click(Sender: TObject);

Var FN: String;

    j: TJPEGImage;

begin

  if PromptForFileName(FN, 'Bitmap|*.bmp|JPEG|*.jpg', '*.jpg', 'Save Image', '.', True) then begin

     if UpperCase(ExtractFileExt(FN)) = '.JPG' then begin

       j := TJPEGImage.Create;

       j.Assign(Image1.Picture.Bitmap);

       j.SaveToFile(FN);

       j.Free;

     end else

       Image1.Picture.Bitmap.SaveToFile(FN);

  end;

end;

​

procedure TForm1.Close1Click(Sender: TObject);

begin Close; end;

​

procedure TForm1.Fill1Click(Sender: TObject);

begin

  with Image1.Picture.Bitmap.Canvas do begin

    Brush.Color := ColorBox1.Selected;

    FillRect(Rect(0,0,Width, Height));

  end;

end;

​

procedure TForm1.Pen1Click(Sender: TObject);

begin

  Pen1.Checked := not Pen1.Checked; 

end;

​

procedure TForm1.Attrib1Click(Sender: TObject);

begin Fractal(Image1, Byte(not RadioButton1.Checked), ColorBox1.Selected, dNIL);end;

procedure TForm1.xor1Click(Sender: TObject);

begin Fractal(Image1, Byte(not RadioButton1.Checked), ColorBox1.Selected, dXOR);end;

procedure TForm1.or1Click(Sender: TObject);

begin Fractal(Image1, Byte(not RadioButton1.Checked), ColorBox1.Selected, dOR);end;

procedure TForm1.and1Click(Sender: TObject);

begin Fractal(Image1, Byte(not RadioButton1.Checked), ColorBox1.Selected, dAND);end;

procedure TForm1.Intensity1Click(Sender: TObject);

begin Fractal(Image1, Byte(not RadioButton1.Checked), ColorBox1.Selected, dINTENS);end;

​

​

procedure TForm1.Negative1Click(Sender: TObject);

type

    BArray  = array[0..4] of Byte;

    PBArray = ^BArray;

var

    i, j, l: integer;

    PixelLength, m: byte;

    Cl: TColor;

    P: PBArray;

    B: TBitmap;

begin

  B := nil;

  GetBMP(B, Image1.Picture.Bitmap);

  PixelLength := PixelCount(B);

  if PixelLength = 0 then exit;

  m := (PixelLength + 7) shr 3; {Nr of bytes}

  PixelLength := PixelLength div 3;

  with Image1 do begin

    for j:= 0 to Height-1 do begin

      P := B.ScanLine[j];

      for i := 0 to Width-1 do begin

         Cl := TColor(ReadRGB(P, PixelLength));

//         for l := 0 to m-1 do Cl := (Cl shl 8) or P[l];

         Cl := not Cl;

         WriteRGB(TRGBPack(Cl),P, PixelLength);

//         for l := 0 to m-1 do P[l] := (Cl shr (l shl 3)) and $FF;

         inc(Integer(P),m);

      end;

    end;

   Image1.Picture.Graphic := B;

  end;

  B.Free;

end;

​

​

end.

​

​