unit UnitKMLExport; // Il s'agit de l'unité équivalente de GHCaveDraw, qui reste la référence // Ce travail est mutualisé: // Segment administratif: // -- Standalone GHTopoToolBox, à candidater pour le SILL - MIMO (Socle Interministériel de Logiciels Libres) // -- Acquittement graphique des requêtes TIPISTATS // Segment spéléologique // -- Logiciel GHTopo // -- Logiciel GHCaveDraw (Référence) // 07/04/2020: Point de contrôle temporel (contrôle de version) {$WARNING Vérifier cette version} {$mode delphi} interface uses Classes, SysUtils, Graphics, math; type { TKMLExport } TKMLExport = class strict private FP : TextFile; procedure BeginPlacemark(const Indent: integer; const ID: string); function CheckLatLon(const QLat, QLon: double): boolean; procedure EndPlacemark(const Indent: integer); //FListeCommands: TStringList; private FKMLFilename: string; //FSetOfCoords: string; procedure WriteRawLine(const S: string); function RealEscapeString(const S: string): string; function FormatterVersionEncodageXML(const version: string; const encodage: string): string; procedure BaliseOuvrante(const Indent: integer; const S: string); procedure BaliseFermante(const Indent: integer; const S: string); procedure WriteTagValue(const Indent: integer; const Key, Value: string); procedure BeginStyle(const Indent: integer; const StyleName: string); procedure EndStyle(const Indent: integer; const StyleName: string); procedure DefineLineStyle(const Indent: integer; const LWidth: double; const LColor: TColor; const Opacity: byte = 255); procedure DefineFillStyle(const Indent: integer; const LColor: TColor; const Opacity: byte = 255); procedure BeginCDATA(const Indent: integer); procedure WriteCDATAString(const Indent: integer; const S: string); procedure EndCDATA(const Indent: integer); public function Initialiser(const Filename: string; const DocumentTitle: string): boolean; procedure Finaliser(); procedure WriteCommentaire(const S: string); procedure BeginFolder(const Indent: integer; const S: string); procedure EndFolder(const Indent: integer; const S: string); procedure DefineStylePoly(const StyleName: string; const LineWidth: double; const LineColor, FillColor: TColor; const LineOpacity, FillOpacity: byte); procedure AddPlacemarkPoint(const QNativeCoordX, QNativeCoordY, QNativeCoordZ, Lat, Lon: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string); procedure BeginPolygon(const Name: string; const StyleURL: string; const QID: string); procedure AddVertex(const Lat, Lon, Alt: double; const IsLast: boolean); procedure EndPolygon(); procedure BeginPolyline(const Name: string; const StyleURL: string; const QID: string); procedure EndPolyline(); end; implementation const KML_OPENGIS_WEBSITE = 'http://www.opengis.net/kml/2.2'; KML_GOOGLE_KML_WEBSITE = 'http://www.google.com/kml/ext/2.2'; W3C_W3_WEBSITE = 'http://www.w3.org/2005/Atom'; W3C_XML_SCHEMA_WEBSITE = 'http://www.w3.org/2001/XMLSchema-instance'; GPX_TOPOGRAPHIX_WEBSITE = 'http://www.topografix.com/GPX/1/0'; const INDENT_PLACEMARK = 6; const KML_KEYWORD_DOCUMENT = 'Document'; KML_KEYWORD_FOLDER = 'Folder'; KML_KEYWORD_PLACEMARK = 'Placemark'; KML_KEYWORD_StyleUrl = 'styleUrl'; KML_KEYWORD_Name = 'name'; KML_KEYWORD_Style = 'Style'; KML_KEYWORD_LineStyle = 'LineStyle'; KML_KEYWORD_PolyStyle = 'PolyStyle'; KML_KEYWORD_Point = 'Point'; KML_KEYWORD_Polygon = 'Polygon'; KML_KEYWORD_Polyline = 'LineString'; KML_KEYWORD_Extrude = 'extrude'; KML_KEYWORD_Tesselate = 'tesselate'; KML_KEYWORD_altitudeMode = 'altitudeMode'; KML_KEYWORD_outerBoundaryIs = 'outerBoundaryIs'; KML_KEYWORD_LinearRing = 'LinearRing'; KML_KEYWORD_Description = 'description'; KML_KEYWORD_Coordinates = 'coordinates'; KML_KEYWORD_MultiGeometry = 'MultiGeometry'; function QFormatterNombreReel(const Value: double; const NbDecs: integer = 2): string; var EWE: String; begin EWE := Format('%%.%df', [NbDecs]); // remplacer les points par des virgules Result := Format(EWE, [Value]); Result := StringReplace(Result, DefaultFormatSettings.DecimalSeparator, '.', [rfReplaceAll, rfIgnoreCase]); end; function QColorToHTMLColor(const Couleur: TColor): string; var R, V, B: byte; begin R := Red(Couleur); V := Green(Couleur); B := Blue(Couleur); Result := Format('#%.2X%.2X%.2X', [R, V, B]); end; { TKMLExport } function TKMLExport.RealEscapeString(const S: string): string; begin //Result := StringReplace(S, '"', '\"', [rfReplaceAll]); // esperluète en premier sinon toutes les entités suivantes vont être cannabisées ;-) Result := StringReplace(S, '&', '&' , [rfReplaceAll]); Result := StringReplace(S, '"', '"' , [rfReplaceAll]); Result := StringReplace(S, '<', '<' , [rfReplaceAll]); Result := StringReplace(S, '>', '>' , [rfReplaceAll]); end; function TKMLExport.Initialiser(const Filename: string; const DocumentTitle: string): boolean; begin Result := False; FKMLFilename := Filename; AssignFile(FP, FKMLFilename); try ReWrite(FP); try {$IFDEF FPC} SetTextCodePage(FP, CP_UTF8); // Forcer l’encodage UTF-8 sous FPC {$ENDIF} Write(FP, #$EF#$BB#$BF); // BOM UTF-8 // Écriture de l'en-tête WriteRawLine(FormatterVersionEncodageXML('1.0', 'UTF-8')); WriteRawLine(Format('', [KML_OPENGIS_WEBSITE, KML_GOOGLE_KML_WEBSITE, KML_OPENGIS_WEBSITE, W3C_W3_WEBSITE])); BaliseOuvrante(1, KML_KEYWORD_DOCUMENT); WriteTagValue(2, 'name', RealEscapeString(DocumentTitle)); Result := True; finally if not Result then begin // En cas d’échec, fermer proprement try CloseFile(FP); except ;;; end; end; end; except on E: Exception do begin Result := False; // Optionnel : journaliser WriteLn(Format('Erreur KML: %s', [E.Message])); end; end; end; procedure TKMLExport.Finaliser(); begin try BaliseFermante(1, KML_KEYWORD_DOCUMENT); BaliseFermante(0, 'kml'); if (IOResult = 0) then CloseFile(FP); finally end; end; procedure TKMLExport.WriteCommentaire(const S: string); begin WriteRawLine(''); end; procedure TKMLExport.DefineStylePoly(const StyleName: string; const LineWidth: double; const LineColor, FillColor: TColor; const LineOpacity, FillOpacity: byte); begin BeginStyle(2, StyleName); DefineLineStyle(4, LineWidth, LineColor, LineOpacity); DefineFillStyle(4, FillColor, FillOpacity); EndStyle(2, StyleName); end; procedure TKMLExport.BeginCDATA(const Indent: integer); begin WriteRawLine(Format('%s', [StringOfChar(' ', Indent)])); end; function TKMLExport.CheckLatLon(const QLat, QLon: double): boolean; begin Result := Math.InRange(QLat, -90.0, 90.0) AND InRange(QLon, -180.0, 180.0); end; procedure TKMLExport.AddPlacemarkPoint(const QNativeCoordX, QNativeCoordY, QNativeCoordZ, Lat, Lon: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string); begin try if (not CheckLatLon(Lat, Lon)) then raise Exception.CreateFmt('Lat %.5f out of [%.5f; %.5f] or Lon %.5f out of [%.5f; %.5f]', [Lat, -90.0, 90.0, Lon, -180.0, 180.0]); BaliseOuvrante(INDENT_PLACEMARK, KML_KEYWORD_PLACEMARK); WriteTagValue(INDENT_PLACEMARK + 2, KML_KEYWORD_Name, QEtiquette); BaliseOuvrante(INDENT_PLACEMARK + 2, KML_KEYWORD_Description); BeginCDATA(INDENT_PLACEMARK + 4); WriteCDATAString(INDENT_PLACEMARK + 4, Format('%s', [self.RealEscapeString(QDesignation)])); WriteCDATAString(INDENT_PLACEMARK + 4, '
'); WriteCDATAString(INDENT_PLACEMARK + 4, Format('Lat: %s, Lon: %s, Alt: %s', [QFormatterNombreReel(Lat, 8), QFormatterNombreReel(Lon, 8), QFormatterNombreReel(QNativeCoordZ, 2)])); WriteCDATAString(INDENT_PLACEMARK + 4, Format('

%s

', [self.RealEscapeString(QDescription)])); WriteCDATAString(INDENT_PLACEMARK + 4, Format('

%s

', [self.RealEscapeString(QObservations)])); WriteCDATAString(INDENT_PLACEMARK + 4, '
'); WriteCDATAString(INDENT_PLACEMARK + 4, Format('X = %s, Y = %s, Z = %s', [QFormatterNombreReel(QNativeCoordX), QFormatterNombreReel(QNativeCoordY), QFormatterNombreReel(QNativeCoordZ)])); EndCDATA(INDENT_PLACEMARK + 4); BaliseFermante(INDENT_PLACEMARK + 2, KML_KEYWORD_Description); BaliseOuvrante(INDENT_PLACEMARK + 2, KML_KEYWORD_Point); WriteTagValue(INDENT_PLACEMARK + 4, KML_KEYWORD_Coordinates, Format('%s, %s, %s', [QFormatterNombreReel(Lon, 8), QFormatterNombreReel(Lat, 8), QFormatterNombreReel(QNativeCoordZ, 2)])); BaliseFermante(INDENT_PLACEMARK + 2, KML_KEYWORD_Point); //*) BaliseFermante(INDENT_PLACEMARK, KML_KEYWORD_PLACEMARK); except raise; // Redéclencher pour l'appelant end; end; procedure TKMLExport.BeginPolygon(const Name: string; const StyleURL: string; const QID: string); begin WriteCommentaire('Polygone: ' + Name); BeginPlacemark(INDENT_PLACEMARK, QID);// BaliseOuvrante(INDENT_PLACEMARK, KML_KEYWORD_PLACEMARK); WriteTagValue(INDENT_PLACEMARK + 2, KML_KEYWORD_Name, Name); WriteTagValue(INDENT_PLACEMARK + 2, KML_KEYWORD_StyleUrl, '#' + StyleURL); BaliseOuvrante(INDENT_PLACEMARK + 2, KML_KEYWORD_Polygon); //WriteTagValue(INDENT_PLACEMARK + 4, KML_KEYWORD_Tesselate, '1'); BaliseOuvrante(INDENT_PLACEMARK + 4, KML_KEYWORD_outerBoundaryIs); BaliseOuvrante(INDENT_PLACEMARK + 6, KML_KEYWORD_LinearRing); BaliseOuvrante(INDENT_PLACEMARK + 8, KML_KEYWORD_Coordinates); //FSetOfCoords := ''; end; procedure TKMLExport.AddVertex(const Lat, Lon, Alt: double; const IsLast: boolean); begin // Espaces non tolérés dans les triplets //FSetOfCoords += Format('%s,%s,%s ', [QFormatterNombreReel(Lon, 8), QFormatterNombreReel(Lat, 8), QFormatterNombreReel(0.00, 0)]); try if (not CheckLatLon(Lat, Lon)) then raise Exception.CreateFmt('Lat %.5f out of [%.5f; %.5f] or Lon %.5f out of [%.5f; %.5f]', [Lat, -90.0, 90.0, Lon, -180.0, 180.0]); WriteRawLine(Format('%s%s,%s,%s ', [StringOfChar(' ', INDENT_PLACEMARK + 8), QFormatterNombreReel(Lon, 8), QFormatterNombreReel(Lat, 8), QFormatterNombreReel(0.0, 2)])); //Alt + 0.01 except raise; // Redéclenche pour l'appelant end; end; procedure TKMLExport.EndPolygon(); begin //WriteLine(FSetOfCoords); BaliseFermante(INDENT_PLACEMARK + 8, KML_KEYWORD_Coordinates); BaliseFermante(INDENT_PLACEMARK + 6, KML_KEYWORD_LinearRing); BaliseFermante(INDENT_PLACEMARK + 4, KML_KEYWORD_outerBoundaryIs); BaliseFermante(INDENT_PLACEMARK + 2, KML_KEYWORD_Polygon); BaliseFermante(INDENT_PLACEMARK, KML_KEYWORD_PLACEMARK); EndPlacemark(INDENT_PLACEMARK); //FSetOfCoords := ''; end; procedure TKMLExport.BeginPolyline(const Name: string; const StyleURL: string; const QID: string); begin WriteCommentaire('Polyligne: ' + Name); BeginPlacemark(INDENT_PLACEMARK, QID);//BaliseOuvrante(INDENT_PLACEMARK, KML_KEYWORD_PLACEMARK); WriteTagValue(INDENT_PLACEMARK + 2, KML_KEYWORD_Name, Name); WriteTagValue(INDENT_PLACEMARK + 2, KML_KEYWORD_StyleUrl, '#' + StyleURL); BaliseOuvrante(INDENT_PLACEMARK + 2, KML_KEYWORD_MultiGeometry); BaliseOuvrante(INDENT_PLACEMARK + 4, KML_KEYWORD_Polyline); //SetAttribut(INDENT_PLACEMARK + 4, KML_KEYWORD_Extrude, '1'); //SetAttribut(INDENT_PLACEMARK + 4, KML_KEYWORD_Tesselate, '1'); //SetAttribut(INDENT_PLACEMARK + 4, KML_KEYWORD_altitudeMode, 'relativeToGround'); // absolute BaliseOuvrante(INDENT_PLACEMARK + 8, KML_KEYWORD_Coordinates); //FSetOfCoords := ''; end; procedure TKMLExport.BeginPlacemark(const Indent: integer; const ID: string); begin WriteRawLine(Format('%s<%s id="%s">', [StringOfChar(' ', Indent), KML_KEYWORD_PLACEMARK, self.RealEscapeString(ID)])); end; procedure TKMLExport.EndPlacemark(const Indent: integer); begin BaliseFermante(Indent, KML_KEYWORD_PLACEMARK); end; procedure TKMLExport.EndPolyline(); begin //WriteLine(FSetOfCoords); BaliseFermante(INDENT_PLACEMARK + 8, KML_KEYWORD_Coordinates); BaliseFermante(INDENT_PLACEMARK + 4, KML_KEYWORD_Polyline); BaliseFermante(INDENT_PLACEMARK + 2, KML_KEYWORD_MultiGeometry); EndPlacemark(INDENT_PLACEMARK); // BaliseFermante(INDENT_PLACEMARK, KML_KEYWORD_PLACEMARK); //FSetOfCoords := ''; end; procedure TKMLExport.WriteRawLine(const S: string); begin WriteLn(fp, S); //FListeCommands.Add(S); end; //****************************************************************************** function TKMLExport.FormatterVersionEncodageXML(const version: string; const encodage: string): string; inline; begin Result := Format('', [version, encodage]); end; procedure TKMLExport.BaliseOuvrante(const Indent: integer; const S: string); begin WriteRawLine(Format('%s<%s>', [StringOfChar(' ', Indent), S])); end; procedure TKMLExport.BaliseFermante(const Indent: integer; const S: string); begin WriteRawLine(Format('%s', [StringOfChar(' ', Indent), S])); end; procedure TKMLExport.BeginFolder(const Indent: integer; const S: string); begin BaliseOuvrante(Indent, KML_KEYWORD_FOLDER); WriteTagValue(Indent + 2, 'name', S); WriteTagValue(Indent + 2, 'open', '1'); end; procedure TKMLExport.EndFolder(const Indent: integer; const S: string); begin BaliseFermante(Indent, KML_KEYWORD_FOLDER); end; procedure TKMLExport.WriteTagValue(const Indent: integer; const Key, Value: string); begin WriteRawLine(Format('%s<%s>%s', [StringOfChar(' ', Indent), Key, Value, Key])); end; procedure TKMLExport.BeginStyle(const Indent: integer; const StyleName: string); begin WriteRawLine(Format('%s<%s id="%s">', [StringOfChar(' ', Indent), KML_KEYWORD_Style, StyleName])); end; procedure TKMLExport.EndStyle(const Indent: integer; const StyleName: string); begin WriteRawLine(Format('%s', [StringOfChar(' ', Indent), KML_KEYWORD_Style, StyleName])); end; procedure TKMLExport.DefineLineStyle(const Indent: integer; const LWidth: double; const LColor: TColor; const Opacity: byte = 255); var EWE: String; begin EWE := Format('%.2X%.2X%.2X%.2X', [Opacity, Blue(LColor), Green(LColor), Red(LColor)]); BaliseOuvrante(Indent, KML_KEYWORD_LineStyle); WriteTagValue(Indent + 2, 'color', EWE); WriteTagValue(Indent + 2, 'width', QFormatterNombreReel(LWidth, 2)); BaliseFermante(Indent, KML_KEYWORD_LineStyle); end; procedure TKMLExport.DefineFillStyle(const Indent: integer; const LColor: TColor; const Opacity: byte = 255); var EWE: String; begin EWE := Format('%.2X%.2X%.2X%.2X', [Opacity, Blue(LColor), Green(LColor), Red(LColor)]); BaliseOuvrante(Indent, KML_KEYWORD_PolyStyle); WriteTagValue(Indent + 2, 'color', EWE); BaliseFermante(Indent, KML_KEYWORD_PolyStyle); end; end.