svn/view/paintfrm.pas

unit paintfrm;

{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

(***************************************)
(* Copyright (C) 2009, SHIRAISHI Kazuo *)
(***************************************)


interface

uses Types,Classes, Graphics, Forms, Controls, Menus,
  StdCtrls, Dialogs, {Printers,} SysUtils, Clipbrd,  ComCtrls,  ExtCtrls,
  LResources;


type

  { TPaintForm }

  TPaintForm = class(TForm)
    FontDialog1: TFontDialog;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Exit1: TMenuItem;
    Option1: TMenuItem;
    Font1: TMenuItem;
    N2: TMenuItem;
    Print1: TMenuItem;
    N3: TMenuItem;
    SaveAs1: TMenuItem;
    Save1: TMenuItem;
    N4: TMenuItem;
    Close1: TMenuItem;
    Edit1: TMenuItem;
    Copy1: TMenuItem;
    Run1: TMenuItem;
    Break1: TMenuItem;
    SaveDialog1: TSaveDialog;
    OpenDialog1: TOpenDialog;
    Open1: TMenuItem;
    Paste1: TMenuItem;
    Show1: TMenuItem;
    TextWindow1: TMenuItem;
    StatusBar1: TStatusBar;
    PaintBox1: TPaintBox;
    procedure Font1Click(Sender: TObject);
    procedure Option1Click(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure Close1Click(Sender: TObject);
    procedure Print1Click(Sender: TObject);
    procedure Copy1Click(Sender: TObject);
    procedure Paste1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Break1Click(Sender: TObject);
    procedure SaveAs1Click(Sender: TObject);
    procedure Save1Click(Sender: TObject);
    procedure Size1Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
    {
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    }
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);

    procedure PaintBox1Click(Sender: TObject);
    procedure E1Click(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure StatusBar1Resize(Sender: TObject);

  private
    mouseX,mouseY:integer;
    MouseClick:boolean;
    mousestate:TShiftState;
    procedure SizeAdjust;
    //procedure CMMouseLeave(var Message:TMessage);message CM_MOUSELEAVE;
    //procedure PolyGonSub(Canvas:TCanvas; const Points:array of TPoint);
  public
     BitMap1:TBitMap;
     BitMapHeight:integer;
     BitMapWidth:integer;
    procedure Clear;
    procedure initial;
    procedure SetSize1;
    procedure setsize2;
    procedure getpoint(var a,b:integer);
    procedure MoveMouse(a,b:integer);
    procedure MousePol(var a,b:integer; var l,r:boolean);
    procedure SetBitmapSize(w,h:integer);
    procedure OpenFile(FileName: string);
    procedure SaveFile(FileName: string);
    procedure SaveFileFormat(FileName: string; pf:TPixelFormat);
    procedure SaveJpegFile(FileName:string; p:integer);
    procedure SaveGifFile(FileName:string);

  end;
var
    paintform:TPaintForm;

implementation
uses  lclintf,  LclType,
     textfrm,base,base2, printbmp,
     myutils, arithmet, sconsts,  graphsys;
{$R *.lfm}

var
   RightMargin:integer=8;
   BottomMargin:integer=60;

procedure TPaintForm.Open1Click(Sender: TObject);
begin
  with TOpenDialog.Create(nil) do
  try
    options:=[ofPathMustExist,ofFileMustExist];
    Filter :=
         s_Bitmap+ '|*.BMP;*.JPG;*.JPEG;*.GIF';  { Set the OpenDialog Filters.}
    DefaultExt:='BMP';                           { Set the default extension }
    if Execute then
    begin
      OpenFile(FileName);
      Caption :=FileName;
    end;
  finally
    free;
  end;
end;
(*
procedure TPaintForm.Open1Click(Sender: TObject);
begin
  OpenDialog1.Filter :=
                          s_Bitmap+ '|*.bmp';
  OpenDialog1.DefaultExt :='bmp';     
  if OpenDialog1.Execute then
    begin
     OpenFile(OpenDialog1.FileName);
     Caption :=OpenDialog1.FileName;
    end;

end;
*)

procedure TPaintForm.Font1Click(Sender: TObject);
begin
    FontDialog1.Font:=Font;
    if FontDialog1.execute then
        Font:=FontDialog1.Font;
    BitMap1.Canvas.Font.assign(Font);
    PaintBox1.Canvas.Font.assign(Font);
end;


procedure TPaintForm.Exit1Click(Sender: TObject);
begin
   Application.terminate;
end;

procedure TPaintForm.Close1Click(Sender: TObject);
begin
     Close;  { Close the form }
end;

procedure TPaintForm.Print1Click(Sender: TObject);
begin
     PrintBitMap(BitMap1);
end;


procedure TPaintForm.Copy1Click(Sender: TObject);
begin
  ClipBoard.Assign(BitMap1);
end;


procedure TPaintForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
   if Application.mainform=self then
      Action:=caFree
   else
      Action:=caMiniMize;
   if MessageDlg('Continue?', mtCustom, [mbOk,MbAbort], 230)=MrAbort then
      raise EStop.create;

end;

procedure TPaintForm.clear;
var
    NewRect:TRect;
    svBrushColor:TColor;
begin
    NewRect:=Rect(0,0,Bitmap1.width,Bitmap1.Height);

    with BitMap1.Canvas do
      begin
        svBrushColor:=Brush.Color ;
        Brush.color:=Mypalette.pal[0] or $2000000;
        FillRect(NewRect);
        Brush.Color:=svBrushColor;
      end;
    //PaintBox1.Canvas.Brush.color:=MyPalette[0];
    //PaintBox1.Canvas.FillRect(NewRect);
    if not HiddenDrawMode then
      PaintBox1.repaint;
end;
{
procedure TPaintForm.clear;
var
    NewRect:TRect;
begin
    NewRect:=Rect(0,0,Bitmap1.width,Bitmap1.Height);
    BitMap1.Canvas.Brush.color:=MyPalette[0] or $2000000;
    BitMap1.Canvas.FillRect(NewRect);
    if not HiddenDrawMode then
      PaintBox1.repaint;
end;
}

procedure TpaintForm.Initial;
begin
    MyPalette.PaletteDisabled:=false;
    //MyPalette.PaletteNumber:=ColorIndexDlg.RadioGroup1.ItemIndex;

    BitMap1.Canvas.Font.assign(Font);
    PaintBox1.Canvas.Font.assign(Font);

   if not KeepGraphic then
    begin
       SetSize1;
       clear;
    end;
end;


procedure TPaintForm.SetSize1;
begin

 try
     if BmpSize >=BMP321 then
        begin
          case BmpSize of
             BMP321:  BitMapHeight:= 321;
             BMP401:  BitMapHeight:= 401;
             BMP501:  BitMapHeight:= 501;
             BMP641:  BitMapHeight:= 641;
             BMP801:  BitMapHeight:= 801;
             BMP1001: BitMapHeight:=1001;
             BMP1281: BitMapHeight:=1281;
             BMP1601: BitMapHeight:=1601;
             BMP2001: BitMapHeight:=2001;
          end;
          BitMapWidth:=BitMapHeight;
        end
     else
        begin
          BitMapWidth:=640;
          case BmpSize of
             BMPpc9801: BitMapHeight:=400;
             BMPdosv: BitMapHeight:=480;
          end;
        end;
    BitMap1.width:=BitMapWidth;
    BitMap1.Height:=BitMapHeight;

    SetSize2;
 except
    if BMPsize<>BMP321 then
     begin
       BmpSize:=BMP321;
       SetSize1
     end;
 end;

end;


procedure TPaintForm.setsize2;
begin
    PaintBox1.Width:=Bitmap1.width;
    PaintBox1.Height:=Bitmap1.Height ;
    visible:=true;
    ClientWidth := Bitmap1.Width +2; { Adjust clientwidth to match }
    ClientHeight := Bitmap1.Height + 1 + Statusbar1.height;   { Adjust clientheight to match }
    sizeadjust;
    ScreenBMPGraphSys.InitCoordinate
end;


procedure TPaintForm.SizeAdjust;
var
   ScreenClientWidth,ScreenClientHeight:integer;
   h:integer;
 begin
   ScreenClientWidth:= GetSystemMetrics(SM_CXFULLSCREEN);
   ScreenClientHeight:= GetSystemMetrics(SM_CYFULLSCREEN);
   if width<ScreenClientWidth div 8 * 7 then
       left:=ScreenClientwidth-width-12;
   if Height<ScreenClientHeight-25 then
       top:=(ScreenClientHeight-Height)-25;

end;

procedure TPaintForm.FormResize(Sender: TObject);
var
  h,w:integer;
begin
   if Bitmap1=nil then exit;

   w:=Bitmap1.Width + 2;
   h:=BitMap1.Height + 1 + StatusBar1.height;
   if ClientWidth>w then
                   ClientWidth:=w;
   if ClientHeight>h then
                   ClientHeight:=h;
   refresh;
   Application.Processmessages;
end;


procedure TPaintForm.SaveFileFormat(FileName: string; pf:TPixelFormat);
var
  Bitmap2:TBitMap;
begin
    BitMap2:= TBitMap.Create;
    Bitmap2.Assign(BitMap1);
    if pf=pf1bit then
       bitmap2.Monochrome:=true;
    Bitmap2.pixelFormat:=pf;
    BitMap2.SaveToFile(FileName);
    BitMap2.Free;
    refresh;
end;

procedure TPaintForm.SaveJpegFile(FileName:string; p:integer);
var
  jpe:TJpegImage;
begin
  jpe:=TJpegImage.Create;
  try
    if p>0 then
      jpe.CompressionQuality:=p;
    jpe.Assign(BitMap1);
    //jpe.Compress;       //Lazarus���������������
    jpe.SaveToFile(FileName);
  finally
    jpe.Free;
  end;
end;

procedure TPaintForm.SaveGifFile(FileName:string);
var
  gif:TGifImage;
begin
  gif:=TGifImage.create;
  try
     gif.Assign(Bitmap1);
     //gif.Optimize([ooCleanup],rmNone,dmNearest,8);  //Lazarus���������������
     gif.SaveToFile(FileName);
  finally
     gif.free
  end;
end;

(*
procedure TPaintForm.OpenFile(FileName: string);
begin
  Paintbox1.visible:=false;
  BitMap1.LoadFromFile(FileName);      
  //Bitmap1.pixelFormat:=pf24bit;
  setSize2;
  Paintbox1.visible:=true;
end;
*)

procedure TPaintForm.OpenFile(FileName: string);
var
  ext:string;
  jpe:TJPegImage;
  gif:TGifImage;
begin
  Paintbox1.visible:=false;
  ext:=UpperCase( ExtractFileExt(FileName));
  if ext='.BMP' then
    BitMap1.LoadFromFile(FileName)        { Load the image from disk }

  else if ext='.GIF' then
    begin
      gif:=TGifImage.create;
      try
         gif.LoadFromFile(FileName);
         BITMAP1.Assign(gif);
      finally
         gif.Free;
      end;
    end

  else
    begin
      jpe:=TJpegImage.create;
      try
        jpe.LoadFromFile(FileName);
        //jpe.DIBNeeded;
        BitMap1.Assign(jpe);
      finally
        jpe.Free;
      end;
    end;
  Bitmap1.pixelFormat:=pf24bit;   //���������������
  setSize2;
  Paintbox1.visible:=true;
end;


procedure TPaintForm.SetBitmapSize(w,h:integer);
begin
     Paintbox1.Visible:=false;
     Bitmap1.width:=w;
     Bitmap1.height:=h;
     SetSize2;
     Paintbox1.visible:=true;
end;


procedure TPaintForm.Break1Click(Sender: TObject);
begin
    CtrlBreakHit:=true ;
    //FrameForm.SetBreakMessage;
end;


procedure TPaintForm.PaintBox1Click(Sender: TObject);
begin
    MouseClick:=true;
end;

procedure TPaintForm.FormCreate(Sender: TObject);
begin
   OpenDialog1.Title:=s_OpenFile;
   SaveDialog1.Title:=s_SaveFile;
   Break1.ShortCut:=ShortCut(Word(BreakKey), [ssCtrl]);

   with Font do
        begin
           CharSet:=OEM_CHARSET;
           style:=[];
        end;
        with TMyIniFile.create('PaintFont') do
           begin
             RestoreFont(Font);
             RightMargin:=ReadInteger('RightMargin',RightMargin);
             BottomMargin:=ReadInteger('BottomMargin',BottomMargin);
             free
           end;

    BitMap1:= TBitMap.Create;
    Bitmap1.pixelFormat:=pf24bit;
    Bitmap1.Canvas.Font.Assign(Font);
    NotXorMode:=false;
    HiddenDrawMode:=false;
    ScreenBMPGraphSys.SetUp;
    SetSize1;

    Visible:=false;   //Windowstate:=wsMinimized;
    //Application.ProcessMessages;

end;

procedure TPaintForm.FormDestroy(Sender: TObject);
begin
   BitMap1.Free;
   BitMap1:=nil;

   with TMyIniFile.create('PaintFont') do
     begin
        StoreFont(Font);
        free
     end;
end;

procedure TPaintForm.SaveAs1Click(Sender: TObject);
var
   ext:string;
begin
    ext:='';
    SaveDialog1.FileName:=ChangeFileExt(Caption,ext);
    if SaveDialog1.Execute then
      begin
         Caption :=SaveDialog1.FileName;
         ext:=UpperCase( ExtractFileExt(Caption));
         if ext='.BMP' then
           begin
             if SaveDialog1.FilterIndex=0{1} then         //Delphi���index���������������?
                SaveFile(Caption)
             else if SaveDialog1.FilterIndex=1{2} then
                SaveFileFormat(Caption,pf4bit)
             else
                SaveFileFormat(Caption,pf1bit);
           end
         else if (ext='.JPG') or (ext='.JPEG') or (ext='.JPE') then
             saveJpegFile(Caption,0)
         else if ext='.GIF' then
             saveGifFile(Caption)
      end;
end;

(*
procedure TPaintForm.SaveAs1Click(Sender: TObject);
begin
    SaveDialog1.FileName:='*.BMP';      //ChangeFileExt(Caption,'.bmp');
    if SaveDialog1.Execute then
      begin
         Caption :=SaveDialog1.FileName;
         if SaveDialog1.FilterIndex=1 then
            SaveFile(Caption)
         else if SaveDialog1.FilterIndex=2 then
            SaveFileFormat(Caption,pf8bit)
         else
            SaveFileFormat(Caption,pf1bit);
      end;
end;
*)

procedure TPaintForm.Save1Click(Sender: TObject);
begin
    if Caption='' then
       SaveAs1Click(Sender)
    else
       SaveFile(Caption)
end;

procedure TPaintForm.OPtion1Click(Sender: TObject);
begin
   // SetOption
end;

procedure TPaintForm.Size1Click(Sender: TObject);
begin
  //  OptionSizeDlg.Execute;
  //  SetSize1
end;

procedure TPaintForm.Paste1Click(Sender: TObject);
begin
  //if ClipBoard.Provides('image/delphi.bitmap')  then
   begin
     Paintbox1.Visible:=false;
     BitMap1.Assign(ClipBoard); 
     //Bitmap1.pixelFormat:=pf24bit;
     SetSize2;
     Paintbox1.visible:=true;
   end;
end;


procedure TPaintForm.E1Click(Sender: TObject);
begin
   TextForm.Visible:=true;
   TextForm.BringToFront
end;

procedure TPaintForm.PaintBox1Paint(Sender: TObject);
begin
  if not HiddenDrawMode then
      PaintBox1.Canvas.Draw(0,0,BitMap1);
end;

procedure TPaintForm.StatusBar1Resize(Sender: TObject);
begin

end;


{
procedure TPaintForm.CMMouseLeave(var Message:TMessage);
begin
   inherited;
   With statusBar1 do
   begin
      Panels[0].text := '';
      Panels[0].text := '';
   end;
   mousestate:=[];    //2004.8.22
   Set8087CW(controlword);
end;
}


{
procedure TPaintForm.GetPoint(var a,b:integer);
var
   svCtrlBreakHit:boolean;
begin
   svCtrlBreakHit:=CtrlBreakHit;
   CtrlBreakHit:=false;
   MouseClick:=false;
   repeat
       sleep(10);IdleImmediately;
   until MouseClick or CtrlBreakHit;
   a:=mouseX;
   b:=mouseY;
   CtrlBreakHit:=CtrlBreakHit or svCtrlBreakHit;
end;
}

procedure TPaintForm.GetPoint(var a,b:integer);
var
   svCtrlBreakHit:boolean;
begin
   svCtrlBreakHit:=CtrlBreakHit;
   CtrlBreakHit:=false;
   MouseClick:=false;
   repeat
       sleep(10);IdleImmediately;
       if CtrlBreakHit then
          if MessageDlg(s_ConfirmToBreak,mtConfirmation,[mbOk,mbAbort],0)=mrAbort then
             raise EStop.create
          else
             begin
                CtrlBreakHit:=false;
                svCtrlBreakHit:=true;
             end;
   until MouseClick ;
   a:=mouseX;
   b:=mouseY;
   CtrlBreakHit:=CtrlBreakHit or svCtrlBreakHit;
end;


procedure TPaintForm.MoveMouse(a,b:integer);
var
   P:TPoint;
begin
  P.X:= a;
  P.Y:= b;
  Mouse.CursorPos:=PaintBox1.ClientToScreen(P);
end;


procedure TPaintForm.MousePol(var a,b:integer; var l,r:boolean);
begin
   IdleImmediately;
   a:=mouseX;
   b:=mouseY;
   l:=ssleft in mousestate;
   r:=ssright in mousestate;
end;

procedure TPaintForm.SaveFile(FileName: string);
begin
    BitMap1.SaveToFile(FileName);
    refresh;
end;

(*
procedure TPaintForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
   a,b:number;
begin
    Set8087CW(controlword);
    MouseX:=x;
    MouseY:=y;

    if (sender=Paintbox1) and not invalidCoordinate  then
     begin
      convert(ScreenBMPGraphSys.Virtualx(x),a);
      convert(ScreenBMPGraphSys.Virtualy(y),b);
      round9(a);
      round9(b);
      StatusBar1.Panels[0].text:=DStr(a);
      StatusBar1.Panels[1].text:=DStr(b);
     end
     else
     begin
      StatusBar1.Panels[0].text:='';
      StatusBar1.Panels[1].text:='';
     end
end;
*)

procedure TPaintForm.PaintBox1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
var
   a,b:number;
begin
    MouseX:=x;
    MouseY:=y;

    if (sender=Paintbox1) and not invalidCoordinate  then
     begin
      convert(ScreenBMPGraphSys.Virtualx(x),a);
      convert(ScreenBMPGraphSys.Virtualy(y),b);
      round9(a);
      round9(b);
      StatusBar1.Panels[0].text:=DStr(a);
      StatusBar1.Panels[1].text:=DStr(b);
     end
     else
     begin
      StatusBar1.Panels[0].text:='';
      StatusBar1.Panels[1].text:='';
     end;
end;


procedure TPaintForm.PaintBox1MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
    mousestate:=shift;
    mouseX:=x;
    mouseY:=y;
{$IFDEF LclGTK2} //Bug?
    MouseState:=[];
{$ENDIF}
{$IFDEF LclCarbon} //Bug?
    MouseState:=[];
{$ENDIF}
end;

procedure TPaintForm.PaintBox1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
    mousestate:=shift;
    mouseX:=x;
    mouseY:=y;
end;

initialization


finalization

end.