Tekening

object frmTekening: TfrmTekening
  Left = 272
  Height = 240
  Top = 140
  Width = 320
  Caption = 'Tekening'
  Color = clWhite
  KeyPreview = True
  OnClose = FormClose
  OnCreate = FormCreate
  OnKeyDown = FormKeyDown
  OnMouseDown = FormMouseDown
  OnMouseMove = FormMouseMove
  OnMouseUp = FormMouseUp
  OnPaint = FormPaint
  OnUTF8KeyPress = FormUTF8KeyPress
  Position = poDesktopCenter
  LCLVersion = '1.0.10.0'
  WindowState = wsFullScreen
end

unit f_main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, LCLType;

type

  TDrawingState = (dsNothing, dsDrawing, dsErasing);

  { TfrmTekening }

  TfrmTekening = class(TForm)
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormPaint(Sender: TObject);
    procedure FormUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char);
  private
    { private declarations }
    FPNG: TPortableNetworkGraphic;
    FColor: TColor;
    FDrawing: TDrawingState;
    FSkip: Boolean;

    procedure MoveTo(const X, Y: Integer);
    procedure LineTo(const X, Y: Integer); overload;
    procedure LineTo(const X, Y: Integer; const AColor: TColor); overload;
    procedure TextOut(const ACanvas: TCanvas; const AText: string);
  public
    { public declarations }
  end;

var
  frmTekening: TfrmTekening;

implementation
uses
  LCLIntf;

{$R *.lfm}

{ TfrmTekening }

procedure TfrmTekening.FormCreate(Sender: TObject);
var
  XY: TPoint;
begin
  FPNG := TPortableNetworkGraphic.Create;
  FPNG.PixelFormat := pf32bit;
  FPNG.Transparent := False;
  FPNG.SetSize(ClientWidth, ClientHeight);
  FPNG.Canvas.Brush.Style := bsSolid;
  FPNG.Canvas.Brush.Color := Self.Color;
  FPNG.Canvas.FillRect(0, 0, FPNG.Width, FPNG.Height);

  FColor := clPurple;
  FPNG.Canvas.Pen.Color := FColor;
  FPNG.Canvas.Pen.Width := 10;
  FPNG.Canvas.Font.Size := 30;

  Self.Canvas.Pen.Color := FColor;
  Self.Canvas.Pen.Width := 10;
  Self.Canvas.Font.Size := 30;

  FDrawing := dsDrawing;
  FSkip := True;
end;

procedure TfrmTekening.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
const
  cKeyColors: array[VK_F1..VK_F12] of TColor =
    ( $00000000  // F1
    , $000000FF  // F2
    , $0000FF00  // F3
    , $0000FFFF  // F4
    , $00FF0000  // F5
    , $00FF00FF  // F6
    , $00FFFF00  // F7
    , $00000088  // F8
    , $00008800  // F9
    , $00880000  // F10
    , $00888888  // F11
    , $00880088  // F12
    );
begin
  if Key in [VK_F1..VK_F12] then begin
    FColor := cKeyColors[Key];
    Key := 0;
  end;
end;

procedure TfrmTekening.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  OnMouseDown := nil;
  OnMouseMove := nil;

  FPNG.SaveToFile(IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME')) + 'tekening-' + FormatDateTime('yyyy-MM-dd_hh.nn.ss', Now) + '.png');
  FPNG.Free;
end;

procedure TfrmTekening.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  LColor: TColor;
begin
  MoveTo(X, Y);
  if FDrawing <> dsNothing then begin
    FDrawing := dsNothing;
  end else begin
    if ssLeft in Shift then begin
      FDrawing := dsDrawing;
      LColor := FColor;
    end else begin
      FDrawing := dsErasing;
      LColor := Self.Color;
    end;
    LineTo(X, Y, LColor);
  end;
end;

procedure TfrmTekening.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  LColor: TColor;
begin
  if FSkip or (FDrawing = dsNothing) then begin
    MoveTo(X, Y);
  end else begin
    if FDrawing = dsDrawing then
      LColor := FColor
    else
      LColor := Self.Color;
    LineTo(X, Y, LColor);
  end;
  FSkip := False;
end;

procedure TfrmTekening.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin

end;

procedure TfrmTekening.FormPaint(Sender: TObject);
begin
  Self.Canvas.Draw(ClientOrigin.X, ClientOrigin.Y, FPNG);
end;

procedure TfrmTekening.FormUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char
  );
begin
  if (UTF8Key >= #32) then begin
    TextOut(FPNG.Canvas, UTF8String(UTF8Key));
    TextOut(Self.Canvas, UTF8String(UTF8Key));
    FSkip := True;
  end;
end;

procedure TfrmTekening.MoveTo(const X, Y: Integer);
begin
  FPNG.Canvas.MoveTo(X, Y);
  Canvas.MoveTo(X, Y);
end;

procedure TfrmTekening.LineTo(const X, Y: Integer);
begin
  FPNG.Canvas.LineTo(X, Y);
  Canvas.LineTo(X, Y);
end;

procedure TfrmTekening.LineTo(const X, Y: Integer; const AColor: TColor);
var
  OldColor, OldPNGColor: TColor;
begin
  OldPNGColor := FPNG.Canvas.Pen.Color;
  OldColor := Self.Canvas.Pen.Color;
  try
    FPNG.Canvas.Pen.Color := AColor;
    Self.Canvas.Pen.Color := AColor;

    LineTo(X, Y);
  finally
    FPNG.Canvas.Pen.Color := OldPNGColor;
    Self.Canvas.Pen.Color := OldColor;
  end;
end;

procedure TfrmTekening.TextOut(const ACanvas: TCanvas; const AText: string);
begin
  ACanvas.Font.Color := FColor;
  ACanvas.Brush.Style := bsClear;
  ACanvas.TextOut(ACanvas.PenPos.X, ACanvas.PenPos.Y, AText);
end;

end.

<?xml version="1.0"?>
<CONFIG>
  <ProjectOptions>
    <Version Value="9"/>
    <General>
      <SessionStorage Value="InProjectDir"/>
      <MainUnit Value="0"/>
      <Title Value="tekening"/>
      <ResourceType Value="res"/>
      <UseXPManifest Value="True"/>
      <Icon Value="0"/>
    </General>
    <i18n>
      <EnableI18N LFM="False"/>
    </i18n>
    <VersionInfo>
      <StringTable ProductVersion=""/>
    </VersionInfo>
    <BuildModes Count="1">
      <Item1 Name="Default" Default="True"/>
    </BuildModes>
    <PublishOptions>
      <Version Value="2"/>
      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
      <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
    </PublishOptions>
    <RunParams>
      <local>
        <FormatVersion Value="1"/>
        <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
      </local>
    </RunParams>
    <RequiredPackages Count="1">
      <Item1>
        <PackageName Value="LCL"/>
      </Item1>
    </RequiredPackages>
    <Units Count="2">
      <Unit0>
        <Filename Value="tekening.pas"/>
        <IsPartOfProject Value="True"/>
        <UnitName Value="tekening"/>
      </Unit0>
      <Unit1>
        <Filename Value="f_main.pas"/>
        <IsPartOfProject Value="True"/>
        <ComponentName Value="frmTekening"/>
        <HasResources Value="True"/>
        <ResourceBaseClass Value="Form"/>
        <UnitName Value="f_main"/>
      </Unit1>
    </Units>
  </ProjectOptions>
  <CompilerOptions>
    <Version Value="11"/>
    <Target>
      <Filename Value="tekening"/>
    </Target>
    <SearchPaths>
      <IncludeFiles Value="$(ProjOutDir)"/>
      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
    </SearchPaths>
    <Linking>
      <Options>
        <Win32>
          <GraphicApplication Value="True"/>
        </Win32>
      </Options>
    </Linking>
    <Other>
      <CompilerMessages>
        <MsgFileName Value=""/>
      </CompilerMessages>
      <CompilerPath Value="$(CompPath)"/>
    </Other>
  </CompilerOptions>
  <Debugging>
    <Exceptions Count="3">
      <Item1>
        <Name Value="EAbort"/>
      </Item1>
      <Item2>
        <Name Value="ECodetoolError"/>
      </Item2>
      <Item3>
        <Name Value="EFOpenError"/>
      </Item3>
    </Exceptions>
  </Debugging>
</CONFIG>

program tekening;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset
  Forms, f_main
  { you can add units after this };

{$R *.res}

begin
  RequireDerivedFormResource := True;
  Application.Initialize;
  Application.CreateForm(TfrmTekening, frmTekening);
  Application.Run;
end.