Unité svgcanvasunit.pas

Commenter

Contenu du snippet

Suite du code précédent:

Génère du SVG en dessinant dans un canevas.

PS: Common.pas:

Cette unité étant commune avec un logiciel de spéléologie, on supprimera les sections inutiles.

Source / Exemple : 


unit SVGCanvasUnit;
interface
uses
  SysUtils,
  Classes,
  Common,
  Graphics;
type TSVGCanvas = class
    constructor Create;
    destructor  Destroy; override;
  private
    FSVGFile: string;
    FCommentaire: string;
    FNbWrittenLines: integer;
    FScale: double;
    FFont : TFontPSProperties;
    FPen  : TPenPSProperties;
    FBrush: TBrushPSProperties;
    FXMin,
    FXMax,
    FYMin,
    FYMax : Double;
    // pour SVG uniquement: définition de la chaine de caractères de description
    // du crayon et de la brosse
    FPenStr  : string;
    FBrushStr: string;

  public
    function  InitializeDocument: boolean;
    procedure FinalizeDocument;
    // limites du dessin
    procedure SetDrawingBounds(const X1, Y1, X2, Y2: Double);
    // définition des couleurs et fontes
    procedure SetPen(const Value: TPenPSProperties);
    function  GetPen: TPenPSProperties;
    procedure SetBrush(const Value: TBrushPSProperties);
    function  GetBrush: TBrushPSProperties;
    procedure SetFont(const Value: TFontPSProperties);
    procedure SetDefaultPen(const Value: TPenPSProperties);
    procedure SetDefaultBrush(const Value: TBrushPSProperties);
    
    //****************************
    procedure SaveToFile;
    // définition de commentaires
    procedure WriteCommentaire(const s: string);
    procedure WriteCommand(const s: string);
    // définition de couches
    procedure BeginLayer(const LayerName: string);
    procedure EndLayer(const LayerName: string);
    // routines de dessin
    procedure MoveTo(const X,Y: Double);
    procedure LineTo(const X,Y: Double);
    procedure DrawPoint(const X,Y: Double);
    procedure DrawLine(const X1, Y1, X2, Y2: Double);
    procedure DrawCircle(const XC, YC, R: double);
    procedure DrawPolylign(const Points: array of TPoint2Df);
    procedure DrawPolygon(const Points: array of TPoint2Df);
    procedure DrawBorderedPolygon(const Points: array of TPoint2Df);
    procedure TextOut(const X,Y: Double; const Text: string);
    function  SVGColor(const C:TColor):string;
    //*)
    //*******************
    property SVGFile: string read FSVGFile write FSVGFile;
    property Commentaire: string read FCommentaire write FCommentaire;
    property Scale: double read FScale write FScale;

end;

implementation
var
  pSVGFILE: TextFile;

procedure DisplayMsg(const Str: string);
begin
  ;//WriteLn(Str);
end;
procedure WriteLine(const S: string);
begin
  WriteLn(pSVGFILE, s);
end;

constructor TSVGCanvas.Create;
begin
 inherited Create;
 DisplayMsg(Format('%s.Create',[ClassName]));
 try

 except
 end;
end;
destructor TSVGCanvas.Destroy;
begin
 DisplayMsg(Format('%s.Free',[ClassName]));
 inherited Destroy;
end;
//**** Définition des pinceaux et couleurs
function  TSVGCanvas.SVGColor(const C:TColor):string;
var
  r,g,b: byte;
begin
  R:=GetRValue(C); G:=GetGValue(C); B:=GetBValue(C);
  Result:=Format('#%.2X%.2X%.2X',[R,G,B]);
  //affichermessage(Result);
end;

function TSVGCanvas.GetPen: TPenPSProperties;
begin
  Result:=FPen;
end;
procedure TSVGCanvas.SetPen(const Value: TPenPSProperties);
begin
  FPen:=Value;
  FPenStr:=Format('stroke: %s; stroke-width: %d;',[SVGColor(FPen.Color), round(FPen.fWidth)]);
end;
procedure TSVGCanvas.SetBrush(const Value: TBrushPSProperties);
begin
  FBrush:=Value;
  FBrushStr:=Format('fill="%s"',[SVGColor(FBrush.Color)]);
  // if >sans remplissage> then FBrushStr:='fill="none"';
end;
function  TSVGCanvas.GetBrush: TBrushPSProperties;
begin
  Result:=FBrush;
end;

procedure TSVGCanvas.SetFont(const Value: TFontPSProperties);
begin
  ;
end;
procedure TSVGCanvas.SetDefaultPen(const Value: TPenPSProperties);
begin
;
end;
procedure TSVGCanvas.SetDefaultBrush(const Value: TBrushPSProperties);
begin
;
end;
//*******************
procedure TSVGCanvas.SetDrawingBounds(const X1, Y1, X2, Y2: Double);
begin
  FXMin:=X1;
  FYMin:=Y1;
  FXMax:=X2;
  FYMax:=Y2;
end;
procedure TSVGCanvas.WriteCommentaire(const s: string);
begin
  WriteLine(Format('<!-- %s -->',[s]));
end;
procedure TSVGCanvas.WriteCommand(const s: string);
begin
  WriteLine(Trim(S));
end;

function  TSVGCanvas.InitializeDocument: boolean;
begin
  Result:=False;
  FNbWrittenLines:=0;
  assignFile(pSVGFILE, FSVGFile);
  try
    ReWrite(pSVGFILE);
    //-------------------------------
    // écriture de l'en tête ici
    // ------------------------------
    WriteLine('<?xml version ="1.0"?>');
    WriteLine('<!-- PostScript File generated by GHTopo');
    WriteLine(Format(' File    : %s',[FSVGFile]));
    WriteLine(Format(' Date    : %s',[DateToStr(Now)]));
    WriteLine(Format(' Comments: %s',[FCommentaire]));
    WriteLine('-->');

    // le dessin
    WriteLine(Format('<svg width="%f" height="%f" viewbox="%f %f %f %f">',
                     [FXMax - FXMin,
                      FYMax - FYMin,
                      FXMin, FYMin, FXMax, FYMax]));

    Result:=True;
  except
    DisplayMsg('Error initializing text file');
    CloseFile(pSVGFILE);
  end;
end;
procedure TSVGCanvas.FinalizeDocument;
begin
  try
    WriteLine('</svg>');
  finally
    CloseFile(pSVGFILE);
  end;
end;
//********* Définition de couches
procedure TSVGCanvas.BeginLayer(const LayerName: string);
begin
  WriteLine(Format('<!-- Begin Layer: %s -->',[LayerName]));
  WriteLine(Format('<g id="%s">',[LayerName]));
end;
procedure TSVGCanvas.EndLayer(const LayerName: string);
begin
  WriteLine('</g>');
  WriteLine(Format('<!-- End Layer: %s -->',[LayerName]));
end;
//********* routines de dessin
procedure TSVGCanvas.MoveTo(const X,Y: Double);
begin
  ;
end;

procedure TSVGCanvas.LineTo(const X,Y: Double);  (* peu utilisé *)
begin
  ;
end;

procedure TSVGCanvas.DrawPoint(const X,Y: Double);
begin
 ;
end;
procedure TSVGCanvas.DrawCircle(const XC, YC, R: double);
begin
;
end;
procedure TSVGCanvas.DrawLine(const X1, Y1, X2, Y2: Double);
begin

  WriteLine(Format('   <line x1="%f" y1="%f" x2="%f" y2="%f" style="%s"/>',
                   [X1,Y1,X2,Y2, FPenStr]));
end;
// dessin d'une polyligne
procedure TSVGCanvas.DrawPolylign(const Points: array of TPoint2Df);
var
  i: integer;
begin
  if (High(Points)<1) then Exit;
  (*
  for i:=1 to High(Points) do
  //*)
end;
// dessin d'un polygone plein sans bordure
procedure TSVGCanvas.DrawPolygon(const Points: array of TPoint2Df);
var
  i: integer;
begin
  if (High(Points)<1) then Exit;
  //WriteLine('newpath');
  
  WriteLine(Format('   <polygon style="fill-rule: nonzero; fill: %s; stroke: none"',
                   [SVGColor(FBrush.Color)]));
  WriteLine(Format('      points="%f, %f ',[Points[0].X, Points[0].Y]));

  for i:=1 to High(Points) do
    WriteLine(Format('              %f, %f ',[Points[i].X, Points[i].Y]));
  WriteLine('   "/>');

end;
// dessin d'un polygone plein avec bordure
procedure TSVGCanvas.DrawBorderedPolygon(const Points: array of TPoint2Df);
var
  i: integer;
begin
  if (High(Points)<1) then Exit;

end;
procedure TSVGCanvas.TextOut(const X,Y: Double; const Text: string);
begin
  WriteLine(Format('<text x="%f" y="%f">%s</text>',[X,Y,Text]));
end;

//*****************************
procedure TSVGCanvas.SaveToFile;
begin
;
end;

end.

Conclusion :


Bugs connus et fonctionnalités:

Unité démarrée récemment.

Polygones, polygones pleins, ellipses, segments, couleurs.

Voir aussi:

http://siliconcavings.chez.tiscali.fr

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (speletux)