unit CadrePascalScript; {$INCLUDE CompilationParameters.inc} interface uses {$INCLUDE SelectionLangues.inc} // insère les unités en fonction de la langue StructuresDonnees, GHTopoGeneralFunctions, unitDatesUtils, unitGHTopoViseesUtils, unitGHTopoStringUtils, unitColorsUtils, unitSolveEquationsPolynomes, Classes, SysUtils, Math, // anciennement Include LCLIntf, LCLType, unitTGHTopoStringArray, {$IFDEF GHTOPO_SIMPLIFIE} unitBRIC4Structures, {$endif GHTOPO_SIMPLIFIE} Graphics, dateutils, LazFileUtils, FastGEO, CallDialogsStdVersion, frmPSDrawing2D, evaluateur_expressions, UnitTGISLineString, {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} ToporobotClasses2012, UnitEntitesExtended, UnitClasseMaillage, unitProfilTopo, UnitFichesTopo, UnitListesSimplesWithGeneriques, UnitGraphes1, UnitTPathBetweenNodes, //GenerationFichesPointsTopo, UnitObjetSerie, //unitProfilTopo, {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} Forms, Controls, Buttons, ActnList, ExtCtrls, PairSplitter, StdCtrls, Dialogs, ComCtrls, SynEdit, SynHighlighterPas, //Ipfilebroker, uPSComponent, uPSCompiler, uPSRuntime, uPSC_classes, uPSComponent_Default, uPSUtils, ubarcodes, BGRABitmap, Clipbrd, UnitRemoteFunctions, UnitExifUtils, UnitLeafletExport, UnitKMLExport, UnitClassPalette, UnitAltimetrieWebServices, sqldb, db, mysql51conn, mysql57conn, mysql56conn, ConvertisseurJPC, SynEditKeyCmds, SynCompletion, unitBinHex, BZGraphesClasses, mailsendu, frmVueCarteOSMSimplifie ; //unitPascalScriptHelpUtilities; //type TVectorResult = array[0..31] of string; type { TCdrPascalScript } TCdrPascalScript = class(TFrame) acLoadPSScript: TAction; acPSExecute: TAction; acPSStop: TAction; acSavePSScript: TAction; acNewScript: TAction; acCopyOutput: TAction; acClearConsoleInput: TAction; acHelp: TAction; acClearConsoleOutput: TAction; acClearConsoleErreur: TAction; acCopyErreur: TAction; Action2: TAction; Action3: TAction; Action4: TAction; AcnLstPascalScript: TActionList; btnFindPSFunc: TButton; DataSource1: TDataSource; editPSOutPutError: TSynEdit; editRecherchePSFuncs: TEdit; editPascalScript: TSynEdit; editPSOutPut: TSynEdit; editPSInput: TSynEdit; ImgLstPascalScript: TImageList; lbStatusPSScript: TStaticText; lsbPSFunctions: TListBox; lsbPSMessages: TListBox; memoHelp: TMemo; PageControlMsgsOutputs: TPageControl; PairSplitter4: TPairSplitter; PairSplitter6: TPairSplitter; PairSplitterSide11: TPairSplitterSide; PairSplitterSide12: TPairSplitterSide; PairSplitterSide7: TPairSplitterSide; PairSplitterSide8: TPairSplitterSide; Panel1: TPanel; pnlEditor: TPanel; pnlButtons: TPanel; PSCustomPlugin1: TPSCustomPlugin; PSImport_Classes1: TPSImport_Classes; PSScriptDebugger1: TPSScriptDebugger; SpeedButton1: TSpeedButton; SpeedButton10: TSpeedButton; SpeedButton11: TSpeedButton; SpeedButton12: TSpeedButton; SpeedButton13: TSpeedButton; SpeedButton14: TSpeedButton; SpeedButton15: TSpeedButton; SpeedButton16: TSpeedButton; SpeedButton17: TSpeedButton; SpeedButton18: TSpeedButton; SpeedButton19: TSpeedButton; SpeedButton2: TSpeedButton; SpeedButton20: TSpeedButton; SpeedButton21: TSpeedButton; SpeedButton22: TSpeedButton; SpeedButton23: TSpeedButton; SpeedButton3: TSpeedButton; SpeedButton4: TSpeedButton; SpeedButton5: TSpeedButton; SpeedButton6: TSpeedButton; SpeedButton7: TSpeedButton; SpeedButton8: TSpeedButton; SpeedButton9: TSpeedButton; SQLConnector1: TSQLConnector; SQLQuery1: TSQLQuery; SQLTransaction1: TSQLTransaction; SynCompletion1: TSynCompletion; SynPasSyn1: TSynPasSyn; tabShtConsoleErreur: TTabSheet; tabShtConsoleInput: TTabSheet; tabShtCompiloMessages: TTabSheet; tabShtConsoleOutput: TTabSheet; procedure acClearConsoleErreurExecute(Sender: TObject); procedure acClearConsoleInputExecute(Sender: TObject); procedure acClearConsoleOutputExecute(Sender: TObject); procedure acCopyErreurExecute(Sender: TObject); procedure acCopyOutputExecute(Sender: TObject); procedure acHelpExecute(Sender: TObject); procedure acLoadPSScriptExecute(Sender: TObject); procedure acNewScriptExecute(Sender: TObject); procedure acPSExecuteExecute(Sender: TObject); procedure acPSStopExecute(Sender: TObject); procedure acSavePSScriptExecute(Sender: TObject); procedure btnFindPSFuncClick(Sender: TObject); procedure editPascalScriptKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure editPascalScriptUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char); procedure editRecherchePSFuncsKeyPress(Sender: TObject; var Key: char); procedure FrameResize(Sender: TObject); procedure lsbPSFunctionsDblClick(Sender: TObject); procedure lsbPSFunctionsSelectionChange(Sender: TObject; User: boolean); procedure PSScriptDebugger1AfterExecute(Sender: TPSScriptDebugger); procedure PSScriptDebugger1Compile(Sender: TPSScriptDebugger); procedure PSScriptDebugger1CompImport(Sender: TObject; x: TPSPascalCompiler); procedure PSScriptDebugger1ExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); procedure PSScriptDebugger1Line(Sender: TObject); procedure SpeedButton12Click(Sender: TObject); procedure SpeedButton13Click(Sender: TObject); procedure SynCompletion1CodeCompletion(var Value: string; SourceValue: string; var SourceStart, SourceEnd: TPoint; KeyChar: TUTF8Char; Shift: TShiftState); procedure SynCompletion1Execute(Sender: TObject); procedure SynCompletion1KeyCompletePrefix(Sender: TObject); procedure SynCompletion1KeyNextChar(Sender: TObject); procedure SynCompletion1KeyPrevChar(Sender: TObject); procedure SynCompletion1PositionChanged(Sender: TObject); procedure SynCompletion1SearchPosition(var APosition: integer); strict private FPalette256: TPalette256; FEvaluateurExpressions: TEvaluateurExpressions; FpTextFiles: Array[0..9] of TextFile; // Pour les fonctions fopen et fclose // aide en ligne des fonctions FOnLineHelpOfFuncs: TStringList; //FGHPascalOnlineHelp: TGHPascalOnlineHelp; // la série courante FCurrentSerie: TObjSerie; FCurrentSerieAssigned: boolean; // pour les fonctions FindFirst FSearchRec: TSearchRec; // TStringList permanent pour certains résultats FListeResults: TStringList; FAttachments : TStringList; // conteneur pour les fonctions de décomposition (split) FGHStringArray: TGHStringArrayExt; // pour la carte OSM FOSMExport: TLeafletExport; // pour la carte KML FKMLExport: TKMLExport; // Convertisseur de coordonnées FConversionCoords: TConversionSysteme; // Services externes Internet FRESTWebServices : TRESTWebService; // Tableau de résultats de requêtes MySQL FSQLResults : TArrayOfTStringList; // Console d'entrée du script FConsoleInputCurrentLine: integer; // numéro de ligne courante // Tableau de résultats de requêtes IGN FArrayOfTPointLatLonAltAcc: TArrayOfTPointLatLonAltAcc; // Carte OSM interactive FdlgVueCarte : TdlgVueCarte; // Pour les envois de mails FSMTPHost : string; FSMTPPort : string; FSMTPUserName : string; FSMTPPassWord : string; // définitions de types procedure DefinesPSTypes(); procedure DefineTypesAndRecords(); procedure DisplayHelpForProc(const MyProc: TPSRegProc); // conteneur pour les fonctions de décomposition (split) procedure ARGV_Clear(); function ARGV_GetNthArgAsString(const idx: integer): string; function ARGV_GetNthArgAsInteger(const idx: integer; const Default: integer): integer; function ARGV_GetNthArgAsFloat(const idx: integer; const Default: double): double; function ARGV_LineSplit(const S: string; const Sep: char): boolean; function ARGV_GetNbArgs(): integer; // conversion de coordonnées function ConversionCoordonneesEPSG(const Src, Tgt: integer; const PointInX, PointInY: double; out PointOutX, PointOutY: double): boolean; // dates function DateTimePascalToSQL(const D: double): string; function DateTimeSqlToPascal(const D: string): double; // depuis la console d'entrée function ConsoleIsEmpty(): boolean; function ConsoleEOF(): boolean; procedure ClearInputConsole(); procedure ReadLineCin(out QOutput: string); procedure WriteToConsoleIn(const S: string); // vers la console de sortie procedure cls(); procedure clsErr(); procedure DisplaySystemInfos(); procedure printf(const FMT: string; const Argv: array of const); procedure printfErr(const FMT: string; const Argv: array of const); procedure DispPSOutput(const Msg: string); procedure DispPSErrOutput(const Msg: string); // Services REST pour IGN et OSM procedure REST_AddPointByXYZ(const QX, QY, QZ: double; const CodeEPSG: integer); function REST_BeginExtractAltitudes(const IdxAltiRESTServer, IdxAltiDataSRC: integer): boolean; procedure REST_AddPointByLatLonAlt(const QLat, QLon, QAlt: double); function REST_Flush(): integer; procedure REST_EndExtractAltitudes(); function REST_GetPointLatLonAltAcc(const idx: integer; out QLat, QLon, QAlt, QAcc, QTagFloat: double; out QTagStr: string): boolean; function REST_GetNbPointsExtraits(): integer; function REST_GetPointXYZAcc(const idx: integer; const CodeEPSG: integer; out QX, QY, QZ, QAcc,QTagFloat: double; out QTagStr: string): boolean; function REST_ExtractProfilAltimetrique(const Lat1, Lon1, Lat2, Lon2: double; const Sampling : integer): boolean; // éval expressions function EvalExpr(const Expr: string; const B: boolean = false; const nZ: double = Infinity): double; // opérations sur les fichiers (10 descripteurs max) function fopen(const Descr: integer; const QFileName: string; const Mode: Char): boolean; function feof(const Descr: integer): boolean; procedure fprint(const Descr: integer; const QLine: string); procedure fprintf(const Descr: integer; const FMT: string; const Argv: array of const); function freadln(const Descr: integer): string; procedure fclose(const Descr: integer); procedure fcloseall(); procedure ForceDirectory(const Dir: string); function GetPathDelimiter(): string; procedure RecenserAdditionalProcs(Sender: TPSScriptDebugger); // spécifique incorporé dans GHTopo {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} // Extraction des coordonnées d'une station topo function ExtractCoordsOfStation(const QSer: TNumeroSerie; const QSt: TNumeroStation; out QX, QY, QZ: double): boolean; // Fiches des stations function BeginListeFichesStations(): boolean; procedure AddFicheStation(const QSr, QSt: integer; const Tag1, Tag2: string); procedure ExportFichesToPDF(const QFilename: string; const QCompressed: boolean); function GetNbFichesStations(): integer; procedure EndListeFichesStations(); // BDD cavité // EPSG courant de la cavité function DOCTOPO_GetCurrentEPSG(): integer; function DOCTOPO_GetNbreStationsOfSerieByIdx(const Idx: integer): integer; function DOCTOPO_GetNbreStationsOfSerieByNoSerie(const NoSerie: integer): integer; function DOCTOPO_GetLengthSerieByNoSerie(const NoSerie: integer): double; function DOCTOPO_GetLengthSerieAtStationByNoSerie(const NoSerie, NoStation: integer): double; function DOCTOPO_GetNumeroEtNomDeSerieByIdx(const Idx: integer; out QNumSerie: TNumeroSerie; out QNomSerie: string; out QNbVisees: integer): boolean; function DOCTOPO_ModifyEntrance(const QIdx: integer; const RefSer, RefSt: integer; const XEntree, YEntree, ZEntree: double; const R, G, B: integer; const NomEntree, IDTerrain, Observ: string): boolean; //function DOCTOPO_ExtractDataFromVisee(const QNumeroSerie: TNumeroSerie; const QNumeroStation: TNumeroStation; out V: array of string): boolean; function DOCTOPO_BeginNewSerie(const QNumeroSerie: integer; const QNoEntrance, QNoReseau: integer; const QSerDep, QPtDep, QSerArr, QPtArr: integer; const QName: string): boolean; procedure DOCTOPO_RemoveSerieByNumSerie(const QNumeroSerie: integer); procedure DOCTOPO_RemoveSerieByIdx(const Idx: integer); function DOCTOPO_AddNewVisee(const QExpe, QCode: integer; const QTypeVisee, QSecteur: integer; const QLong, QAz, QPente, QLG, QLD, QHZ, QHN: double; const QIDTerrain, QObserv: string): boolean; procedure DOCTOPO_EndNewSerie(); // Entrées procedure DOCTOPO_AddNewEntrance(const RefSer, RefSt: integer; const XEntree, YEntree, ZEntree: double; const R, G, B: integer; const NomEntree, IDTerrain, Observ: string); function DOCTOPO_ExtractDataForEntranceByIdx(const Idx: integer; out RefSer, RefSt: integer; out XEntree, YEntree, ZEntree: double; out NomEntree: string): boolean; // Réseaux procedure DOCTOPO_AddNewReseau(const QTypeReseau: integer; const R, G, B: integer; const QNomReseau, QObsReseau: string); // Stations (entites) function STATION_ExtractCoordsFromSerSt(const QSerie: TNumeroSerie; const QStation: TNumeroStation; out QX, QY, QZ: double): boolean; function STATION_FindByID(const QID: string; out QSerie: TNumeroSerie; out QStation: TNumeroStation; out QX, QY, QZ: double): boolean; // Maillages (* X1, X1: Origine du premier profil X2, Y2: Extrémité du premier profil X3, Y3: Un point non aligné aux deux précédents; la zone couverte est un rectangle contenant les points 1, 2 et 3 NbX : Nombre de profils sur x NbY : Nombre de profils sur y M = (1-t).P + t.Q Sens: 1: Sur X 2: Sur Y 4: Les deux //*) // Génération de graphes en HTML procedure GRAPHE_GenererHTML(const PathStart, PathEnd: string; const Width, Height, MenuWidth: integer; const QNameItineraire: string; const QFilename: string; const QEtendueAutourStation: double = 100.00; const QMapBackgroundColor: integer = clCream; const QMapCenterlineColor: integer = clRed); procedure GRAPHE_ExtractNode(const Idx: integer); function GRAPHE_FindShortestPath(const PathStart, PathEnd, Pathname: string): integer; procedure GRAPHE_ExtractPathNode(const QIdx: integer; out QIDStation: string; out QX, QY, QZ: double); // LISTE DES MAILLAGES // ================================================ function LST_Maillages_GenerateSetOfProfilsFromRect(const QNameSet:string; const X1, Y1, X2, Y2, X3, Y3: double; const NbProfilsHorizontaux : integer; const NbProfilsVerticaux : integer; const ColorMinH, ColorMaxH : TColor; const ColorMinV, ColorMaxV : TColor; const Sens: byte): boolean; function LST_Maillages_GenerateSetOfProfilsFromQuad(const QNameSet: string; const X1, Y1, X2, Y2, X3, Y3, X4, Y4: double;const NbProfilsHorizontaux : integer; const NbProfilsVerticaux : integer; const ColorMinH, ColorMaxH : TColor; const ColorMinV, ColorMaxV : TColor; const Sens: byte): boolean; procedure LST_Maillages_CheckerAltimetrieEntrees(const DoAdjustAtMNT: boolean; const DeltaZMax: double); function LST_Maillages_GetNbMaillages(): integer; function LST_Maillages_GetNomMaillage(const Idx:integer): string; function LST_Maillages_LoadMaillageForIdx(const QFilename: string; const Idx: integer): boolean; function LST_Maillages_LoadMaillageAndAdd(const QFilename: string): boolean; procedure LST_Maillages_AddProfil(const ProfilName: string; const X1, Y1, X2, Y2: double; const QCouleur: integer; const QOpacity: byte); function LST_Maillages_GetNbProfils(): integer; procedure LST_Maillages_RemoveProfil(const Idx: integer); procedure LST_Maillages_ClearProfils(); function LST_Maillages_ExtractBounds(out QX1, QY1, QZ1, QX2, QY2, QZ2: double): boolean; function LST_Maillages_ExtractAltitudeFromXY(const QX, QY: double; out QZ: double): boolean; function LST_Maillages_GetNbVertexOfMaillage(const Idx: integer): integer; function LST_Maillages_GetNbTrianglesOfMaillage(const Idx: integer): integer; procedure LST_Maillages_UnloadMaillage(const Idx: integer); {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} // display graphisme function DRAW2D_BeginDrawing(const w, h: integer; const x1, y1, x2, y2: double; const Title: string): boolean; procedure DRAW2D_EndAndDisplayDrawing(); procedure DRAW2D_SetBackgroundColor(const R, G, B, A: byte); procedure DRAW2D_AddLayer(const QLayerName: string; const QAcadIdxColor: integer; const QR, QG, QB, QA: byte); function DRAW2D_AddStyleSheet(const QStylename: string; const QPenColorR, QPenColorG, QPenColorB, QPenOpacity: byte; const QPenWidtdhInPX: byte; const QPenWidthInMM: double; const QBshColorR, QBshColorG, QBshColorB, QBshOpacity: byte; const QBshStyle: byte; const QFntName: string; const QFntColorR, QFntColorG, QFntColorB, QFntOpacity: byte; const QFntSizeInPX: byte; const QFntSizeInMM: double; const QFntStyle: string): integer; procedure DRAW2D_SetStyleSheet(const Idx: integer); function DRAW2D_BeginPolyline(const QIdxLayer: integer; const QName: string; const Closed: boolean): boolean; procedure DRAW2D_AddVertex(const QX, QY: double); procedure DRAW2D_EndPolyline(); function DRAW2D_AddEllipse(const QIdxLayer: integer; const QName: string; const QX, QY, QR1, QR2: double): boolean; function DRAW2D_AddRectangle(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double): boolean; function DRAW2D_AddLine(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double): boolean; function DRAW2D_AddTriangle(const QIdxLayer: integer; const QName: string; const X1, Y1, X2, Y2, X3, Y3: double): boolean; function DRAW2D_AddTexte(const QIdxLayer: integer; const QName: string; const QX, QY, AngleOrientation: double; const QAlignment: byte; const Texte: string): boolean; function DRAW2D_AddMarker(const QIdxLayer: integer; const QName: string; const QX, QY: double; const QSize, QAlignment: byte; const QCaption: string): boolean; function DRAW2D_AddImage(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double; const QFilename: string; const QCaption: string): boolean; // vertex indexés procedure DRAW2D_AddIndexedVertex(const QID: string; const QX, QY, QZ: double); procedure DRAW2D_BeginListeIndexedVertex(); function DRAW2D_FindIndexedVertexByID(const QID: string; out QInternalIdx: integer; out QIdentificateur: string; out QX, QY, QZ: double): boolean; function DRAW2D_getIndexedVertex(const Idx: integer; out QID: string; out QX, QY, QZ: double): boolean; function DRAW2D_getNbIndexedVertex: integer; procedure DRAW2D_EndListeIndexedVertex(); function DRAW2D_BeginIndexedPolyline(const QIdxLayer: integer; const QName: string; const Closed: boolean): boolean; procedure DRAW2D_AddIndexOfVertex(const Cle: string); procedure DRAW2D_EndIndexedPolyline(); function DRAW2D_AddIndexedMarker(const QIdxLayer: integer; const QName: string; const Cle: string; const QOffsetX, QOffsetY: double; const QSize, QAlignment: byte; const QCaption: string): boolean; function DRAW2D_AddIndexedTexte(const QIdxLayer: integer; const QName: string; const Cle: string; const QOffsetX, QOffsetY, AngleOrientation: double; const QAlignment: byte; const Texte: string): boolean; // FTP transfert function FTP_BeginConnexion(const QHost: string; const QPort: integer; const QUser, QPassword: string; out QReturnCode: integer; out QReturnMsg: string): boolean; function FTP_CreateDirectory(const PathFromRoot, QDirectory: TStringDirectoryFilename): boolean; procedure FTP_SetRemoteDirectory(const PathFromRoot: TStringDirectoryFilename); function FTP_GetFileName(const Idx: integer): String; function FTP_GetNbFilesOfLast(): integer; function FTP_ListFilenamesOf(const Path: string): integer; function FTP_SendFile(const QFilename: string): boolean; procedure FTP_EndConnexion(); function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; register; // QRCode procedure QRCode_Generate(const ImgWidth: integer; const QFilenamePNG: string; const QTextToEncode: string); // Exif photos function EXIF_ExtractPositionAndHorodatage(const MyPhoto: string; out Lat, Lon, Alt: double; out Horodatage: double; out MsgErr: string): boolean; // Parcours d'un dossier (non récursif) function FILE_FindFirst(const QPath: string; out QFileFound: string): boolean; function FILE_FindNext(out QFileFound: string): boolean; procedure FILE_FindClose(); //function FILE_FindFirst(const QDirectory, QMask: string): boolean; procedure LST_RESULTS_Clear(); procedure LST_RESULTS_Add(const S: string); function LST_RESULTS_GetItem(const Idx: integer): string; function LST_RESULTS_GetNb(): integer; function LST_RESULTS_LoadFromFile(const QFilename: string): integer; procedure LST_RESULTS_SaveToFile(const QFilename: string); // génération d'une carte OSM function OSM_InitializeMap(const QFilename, QDocTitle: string): boolean; procedure OSM_AddLayer(const QLayerIsAMap, QLayerDisplayed: boolean; const QLayerName: string; const QLayerTitle: string; const QLayerAttribution: string; const QURL: String; const QLayerMarkerStyle: integer; const QLayerMarkerSize: double; const QRed, QGreen, QBlue, QOpacity: integer); function OSM_GetNbLayers(): integer; procedure OSM_WriteHeader(); procedure OSM_AddPlacemark(const QIdxLayer: integer; const QLat, QLon, QAltitude: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string); procedure OSM_FinalizeMap(); function OSM_IdxLayerOf(const QLayerName: string): integer; // génération d'une carte KML function KML_InitializeMap(const QFilename, QDocTitle: string): boolean; procedure KML_BeginFolder(const S: string); procedure KML_EndFolder(const S: string); procedure KML_WriteHeader(); procedure KML_AddPlacemark(const QNativeCoordX, QNativeCoordY: double; const QLat, QLon, QAltitude: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string); procedure KML_FinalizeMap(); // dialogue liste déroulante function DLG_DoDialogListBox(const QTitle: string; out QSelectedIndex: integer; out QSelectedItem: string): boolean; // sauvegrd et rappel du dernier script procedure SaveLastScript(); procedure RetrieveLastScript(); procedure SQL_ClearResults(); // interrogation de BDD function SQL_Connect(const QHostName, QDatabaseName, QUsername, QPassword: string; const QPort: integer = 3306): boolean; procedure SQL_Close(); function SQL_ExecQuery(const QRequest: string): boolean; function SQL_Result_GetNbCols(): integer; function SQL_Result_GetNbRows(): integer; function SQL_Result_GetValue(const ARow, ACol: integer): string; // Spécifique routes procedure DIRA_TGISLineString_ExtractFromString(const LS: string; const Abscisse: double; out Length: double; out AtAbscisseX, AtAbscisseY: double; out MiddleAbscisseX, MiddleAbscisseY: double); // Spécifique BRIC4 {$IFDEF GHTOPO_SIMPLIFIE} function BRIC4_ExtractFromDatagram(const D: string; out Horodatage: string; out Long, Azimut, Pente: single): boolean; function BRIC4_MakeStrDatagramFromMesureLAPHorodatee(const Horodatage: string; const Long, Azimut, Pente: single): string; {$endif GHTOPO_SIMPLIFIE} // Tableau FArrayOfTPointLatLonAltAcc procedure ARR_XYZ_Redim(const Nb: integer); function ARR_XYZ_GetNbElements(): integer; procedure ARR_XYZ_AppendFrom(const Lat, Lon, Alt, Acc, TagFloat: double; const QTag: string); procedure ARR_XYZ_GetFrom(const Idx: integer; out Lat, Lon, Alt, Acc, TagFloat: double; out Tag: string); procedure ARR_XYZ_GetBounds(out CX1, CY1, CZ1, CX2, CY2, CZ2: double); procedure ARR_XYZ_AddBoundingBoxMargin(const M: double); // BinHex function BINHEX_Open(): boolean; procedure BINHEX_SendString(const S: string); function BINHEX_SaveToHex(const QFilename, Description: string): boolean; function BINHEX_LoadFromHex(const QFilename: string): integer; // envoi de mails procedure SMTP_BeginTransaction(const ASubject: string); procedure SMTP_AddLine(const S: string); procedure SMTP_AddAttachment(const S: string); procedure SMTP_EndTransactionAndSend(const ATo: string); // carte interactive function OSM_MAP_WIND_Create(const CodeEPSG: integer; const QX, QY: double): boolean; procedure OSM_MAP_WIND_AddLayer(const QLayerName: string; const QOpacity: single); procedure OSM_MAP_WIND_SetCurrentLayerByIdx(const QIdx: integer); procedure OSM_MAP_WIND_SetCurrentLayerByName(const QLayerName: string); procedure OSM_MAP_WIND_AddPoint(const QX, QY, QZ: double; const QLabel: string); function OSM_MAP_WIND_BeginPolyLine(): boolean; function OSM_MAP_WIND_BeginPolygone(): boolean; procedure OSM_MAP_WIND_AddVertex(const QX, QY, QZ: double); procedure OSM_MAP_WIND_EndPolyLine(const LR, LG, LB, LA: byte; const LineWidth: double); procedure OSM_MAP_WIND_EndPolygone(const LR, LG, LB, LA: byte; const BR, BG, BB, BA: byte; const LineWidth: double); //procedure OSM_MAP_WIND_ procedure OSM_MAP_WIND_Display(); // Palette function PALETTE_256_GetColorByIndex(const Idx: integer; out LR, LG, LB, LA: byte): boolean; //function PALETTE_256_DistanceBetweenColours(constref C1, C2: TGHTopoColor): double; function PALETTE_256_GetIdxNearestColor(const LR, LG, LB, LA: byte): integer; private FPSDrawing2D: TdlgDispGraphisme2D; {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} FDocuTopo : TToporobotStructure2012; FBDDEntites: TBDDEntites; FListeMaillages: TListeOfMaillages; FLesFichesTopo: TFichesTopo; FMyGraphe : TPathFindingGraphe; FShortestPath : TPathBetweenNodes; //FBinHex : TBinHexUtils; {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} FTransfertFTP: TRemoteServicesFTP; procedure ListerPSFunctions(); procedure DispPSCompilerMsg(const Msg: string); procedure NewScript(const ScriptName: string = 'NewScript01'); //////////////////////////////////////////////////////////////////////////////// procedure InitCaptions(); public {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} function Initialiser(const QEvaluateurExpr: TEvaluateurExpressions; const QConvertisseurCoords: TConversionSysteme; const QD: TToporobotStructure2012; const QBDDEntites: TBDDEntites; const ListeMaillages: TListeOfMaillages): boolean; {$else} function Initialiser(const QEvaluateurExpr: TEvaluateurExpressions; const QConvertisseurCoords: TConversionSysteme): boolean; {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} procedure Finaliser(); end; implementation uses DGCDummyUnit; CONST DOSSIER_DE_MES_SCRIPTS = '0000_ScriptsPerso'; CONST MY_LAST_PASCAL_SCRIPT = '000_LastScript.pas'; CONST KML_MAIN_FOLDER = 'KMLDocument'; {$R *.lfm} function psCompilerBeforeOutput(Sender: TPSPascalCompiler): Boolean; var s:string; begin Result:=True; end; function TCdrPascalScript.ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean; register; { the OnUses callback function is called for each "uses" in the script. It's always called with the parameter 'SYSTEM' at the top of the script. For example: uses ii1, ii2; This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'. } begin if Name = 'SYSTEM' then begin //Sender.AddDelphiFunction('procedure MyOwnFunction(Data: string)'); { This will register the function to the script engine. Now it can be used from within the script. } Result := True; end else Result := False; end; procedure TCdrPascalScript.QRCode_Generate(const ImgWidth: integer; const QFilenamePNG: string; const QTextToEncode: string); const MARGE_PERIMETRIQUE = 2; var QR: TBarcodeQR; M: TMatriceResultat; i, j, n: Integer; TailleCarre: double; BMP: TBGRABitmap; procedure QDrawCarre(const u, v: integer); var TC: double; begin BMP.CanvasBGRA.Brush.Color := IIF(M[u, v] = 0, clWhite, clBlack); BMP.CanvasBGRA.Pen.Color := BMP.CanvasBGRA.Brush.Color; TC := MARGE_PERIMETRIQUE * TailleCarre; BMP.CanvasBGRA.Rectangle(round( u * TailleCarre + TC), round( v * TailleCarre + TC), round((u+1) * TailleCarre + TC), round((v+1) * TailleCarre + TC)); end; begin DispPSOutput(Format('MakeQRCode(%d, %s, %s)', [ImgWidth, QFilenamePNG, QTextToEncode])); if ('' = trim(QTextToEncode)) then exit; QR := TBarcodeQR.Create(nil); try QR.ECCLevel := eBarcodeQR_ECCLevel_H; QR.Text := mysqli_real_escape_string(QTextToEncode, false); QR.Generate; QR.MakeMatriceResultat; M := QR.GetMatrixQRResultat; n := QR.GetNbQRTaille; TailleCarre := ImgWidth / (MARGE_PERIMETRIQUE + n + MARGE_PERIMETRIQUE); DispPSOutput(inttostr(n)); BMP := TBGRABitmap.Create(ImgWidth + 2, ImgWidth + 2); try BMP.CanvasBGRA.Pen.Color := clBlack; BMP.CanvasBGRA.Pen.Width := 0; BMP.CanvasBGRA.Pen.Style := psSolid; BMP.CanvasBGRA.Brush.Color := clWhite; BMP.CanvasBGRA.Brush.Style := bsSolid; BMP.CanvasBGRA.Brush.Opacity := 255; BMP.CanvasBGRA.FillRect(0, 0, BMP.Width, BMP.Height); for i := 0 to n - 1 do for j := 0 to n - 1 do QDrawCarre(i, j); BMP.SaveToFile(QFilenamePNG); finally FreeAndNil(BMP); end; finally FreeAndNil(QR); end; end; // wrappers pour fonctions standard // f en préfixe des fonctions, convention C aka fabs(x) function fabs(const X: Double): Double; inline; begin result := abs(X); end; function fexp(X: Double): Double; inline; begin result := exp(X); end; function farctan(X: Double): Double; inline; begin result := arctan(X); end; function farctan2(Y, X: Double): Double; inline; begin result := arctan2(Y, X); end; function fln(X: Double): Double; inline; begin result := ln(X); end; function flog(X: Double): Double; inline; begin result := log10(X); end; //////////////////////////////////////////////////////////////////////////////// { TCdrPascalScript } {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} function TCdrPascalScript.Initialiser(const QEvaluateurExpr: TEvaluateurExpressions; const QConvertisseurCoords: TConversionSysteme; const QD: TToporobotStructure2012; const QBDDEntites: TBDDEntites; const ListeMaillages: TListeOfMaillages): boolean; {$else} function TCdrPascalScript.Initialiser(const QEvaluateurExpr: TEvaluateurExpressions; const QConvertisseurCoords: TConversionSysteme): boolean; {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} const CONSOLE_FONT_SIZE = 10; var i: Integer; procedure ExecScriptBidon(); // pour armer l'aide des fonctions begin pass; end; procedure SetFontsOfEditorAndConsoles(const C: TSynEdit); begin C.Font.Size := CONSOLE_FONT_SIZE; end; begin result := false; ARGV_Clear(); // vider les consoles editPSInput.Clear; editPSOutPut.Clear; editPSOutPutError.Clear; SQLConnector1.Connected := false; // taille de police des consoles SetFontsOfEditorAndConsoles(editPascalScript); SetFontsOfEditorAndConsoles(editPSInput); SetFontsOfEditorAndConsoles(editPSOutPut); SetFontsOfEditorAndConsoles(editPSOutPutError); FOSMExport := TLeafletExport.Create; // Export OSM //FIGNWebServices := TMyIGNWebService.Create; // Service altimétrique IGN FPalette256 := TPalette256.Create; FPalette256.GenerateTOPOROBOTPalette(); FEvaluateurExpressions := QEvaluateurExpr; FConversionCoords := QConvertisseurCoords; FListeResults := TStringList.Create; FAttachments := TStringList.Create; FOnLineHelpOfFuncs := TStringList.Create; FSQLResults := TArrayOfTStringList.Create; FArrayOfTPointLatLonAltAcc.Redim(0); //FGHPascalOnlineHelp := TGHPascalOnlineHelp.Create; //FGHPascalOnlineHelp.Initialiser(); FOnLineHelpOfFuncs.Sorted := false; FOnLineHelpOfFuncs.Clear; FPSDrawing2D := nil; {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} FCurrentSerieAssigned := false; FLesFichesTopo := nil; FDocuTopo := QD; FBDDEntites := QBDDEntites; FListeMaillages := ListeMaillages; FMyGraphe := TPathFindingGraphe.Create; FMyGraphe.Initialiser(FDocuTopo, FBDDEntites); FMyGraphe.ConstruireGraphe(false, false); FShortestPath.EmptyListeNoeuds(); {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} DefinesPSTypes(); DefineTypesAndRecords(); // TODO Ici ou dans RecenserAdditionalProcs() ?; RetrieveLastScript(); PSScriptDebugger1.Compile; PSScriptDebugger1.ClearBreakPoints; InitCaptions(); LST_RESULTS_Clear(); SynCompletion1.CaseSensitive := false; SynCompletion1.ItemList.Clear; SynCompletion1.ItemList.Assign(FOnLineHelpOfFuncs); FSMTPHost := GetSMTPHost(); FSMTPPort := GetSMTPPort(); FSMTPUserName := GetSMTPUserName(); FSMTPPassWord := GetSMTPPassWord(); FdlgVueCarte := nil; // curseurs des PairSplitters PairSplitter4.Cursor := crHSplit; PairSplitter4.Cursor := crVSplit; result := true; end; procedure TCdrPascalScript.Finaliser(); begin try ARGV_Clear(); SaveLastScript(); FOnLineHelpOfFuncs.Clear; LST_RESULTS_Clear(); FSQLResults.ClearListe(); FArrayOfTPointLatLonAltAcc.Redim(0); FPalette256.Finaliser(); //FGHPascalOnlineHelp.Finaliser(); finally FreeAndNil(FPalette256); FreeAndNil(FOSMExport); FreeAndNil(FListeResults); FreeAndNil(FAttachments); //FreeAndNil(FGHPascalOnlineHelp); end; end; procedure TCdrPascalScript.DefineTypesAndRecords(); begin //PSScriptDebugger1.Comp.; //PSScriptDebugger1. end; // Daclaration des fonctions utilisables ds GHTopo //procedure TCdrPascalScript.RecenserAdditionalProcs(Sender: TPSScriptDebugger); {$INCLUDE IncludeRecenserAdditionalProcs.inc} //******************************************************************************** procedure TCdrPascalScript.PSScriptDebugger1AfterExecute(Sender: TPSScriptDebugger); begin DispPSOutput('*******************************'); DispPSOutput('*** Script terminated ****'); lbStatusPSScript.Caption := 'DONE'; end; procedure TCdrPascalScript.PSScriptDebugger1Compile(Sender: TPSScriptDebugger); begin lsbPSMessages.Clear; lbStatusPSScript.Caption := 'COMPILING'; RecenserAdditionalProcs(Sender); ListerPSFunctions(); lbStatusPSScript.Caption := 'COMPILED'; end; procedure TCdrPascalScript.PSScriptDebugger1CompImport(Sender: TObject; x: TPSPascalCompiler); begin SIRegisterTStrings(X, True); //Both are SIRegisterTStringList(X); //needed!! end; procedure TCdrPascalScript.PSScriptDebugger1ExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); begin pass; //RIRegister_Std(AClassImporter); //RIRegisterTObject(AClassImporter); //RIRegisterTStrings(X, True); //Both are //RIRegisterTStringList(X); //Needed !! end; procedure TCdrPascalScript.PSScriptDebugger1Line(Sender: TObject); begin Application.ProcessMessages; lbStatusPSScript.Color := clYellow; lbStatusPSScript.Caption := BoolToStr(PSScriptDebugger1.Running, 'RUNNING', 'READY'); end; procedure TCdrPascalScript.SpeedButton12Click(Sender: TObject); begin pass; end; procedure TCdrPascalScript.SpeedButton13Click(Sender: TObject); begin pass; end; procedure TCdrPascalScript.SynCompletion1CodeCompletion(var Value: string; SourceValue: string; var SourceStart, SourceEnd: TPoint; KeyChar: TUTF8Char; Shift: TShiftState); var n, i: Integer; EWE: String; begin Value := ''; n := -1; EWE := UpperCase(SourceValue); for i := 0 to SynCompletion1.ItemList.Count - 1 do begin if (pos(EWE, Uppercase(SynCompletion1.ItemList[i])) > 0) then begin n := i; break; end; end; if (n >= 0) then Value := SynCompletion1.ItemList[n]; DispPSOutput(format('*** SynCompletion1CodeCompletion: Idx: %d / %d - Value: %s, SourceValue: %s', [n, SynCompletion1.ItemList.Count, Value, SourceValue])); end; procedure TCdrPascalScript.SynCompletion1Execute(Sender: TObject); begin //SynCompletion1. DispPSOutput('*** SynCompletion1Execute()'); end; procedure TCdrPascalScript.SynCompletion1KeyCompletePrefix(Sender: TObject); begin DispPSOutput('*** SynCompletion1KeyCompletePrefix()'); end; procedure TCdrPascalScript.SynCompletion1KeyNextChar(Sender: TObject); begin DispPSOutput('*** SynCompletion1KeyNextChar()'); end; procedure TCdrPascalScript.SynCompletion1KeyPrevChar(Sender: TObject); begin DispPSOutput('*** SynCompletion1KeyPrevChar()'); end; procedure TCdrPascalScript.SynCompletion1PositionChanged(Sender: TObject); begin DispPSOutput('*** SynCompletion1PositionChanged()'); end; procedure TCdrPascalScript.SynCompletion1SearchPosition(var APosition: integer); var EWE: String; begin EWE := ''; //editPascalScript.GetToken; DispPSOutput(format('*** SynCompletion1SearchPosition(%d - L%dC%d): %s', [APosition, editPascalScript.CaretY, editPascalScript.CaretX, EWE])); end; procedure TCdrPascalScript.DefinesPSTypes(); begin pass; (* PSScriptDebugger1.Defines.Clear; PSScriptDebugger1.Defines.Add('type TPoint3Df = record'); PSScriptDebugger1.Defines.Add(' X: double;'); PSScriptDebugger1.Defines.Add(' Y: double;'); PSScriptDebugger1.Defines.Add(' Z: double;'); PSScriptDebugger1.Defines.Add('end;'); //*) end; procedure TCdrPascalScript.lsbPSFunctionsDblClick(Sender: TObject); var EWE: String; begin EWE := Trim(lsbPSFunctions.Items[lsbPSFunctions.ItemIndex] + '('); editPascalScript.InsertTextAtCaret(EWE); editPascalScript.CaretX := editPascalScript.CaretX + Length(EWE); editPascalScript.SelStart := editPascalScript.CaretX; editPascalScript.SelEnd := editPascalScript.CaretX; end; procedure TCdrPascalScript.lsbPSFunctionsSelectionChange(Sender: TObject; User: boolean); var n: Integer; EWE: String; begin n := lsbPSFunctions.ItemIndex; if (n = -1) then exit; EWE := FOnLineHelpOfFuncs.Strings[n]; memoHelp.Text := EWE; end; procedure TCdrPascalScript.acSavePSScriptExecute(Sender: TObject); const PRGM = 'program '; var EWE: TStringDirectoryFilename; TD: TSaveDialog; function getScriptName(): string; var i, Nb, P: Integer; WU: String; begin result := 'Script001.pas'; Nb := editPascalScript.Lines.Count; if (Nb = 0) then exit; for i := 0 to Nb-1 do begin WU := editPascalScript.Lines[i]; P := Pos(PRGM, LowerCase(WU)); if (P > 0) then begin Result := Trim(System.Copy(WU, Length(PRGM), Length(WU))); Result := StringReplace(Result, ';', '', [rfReplaceAll]); //Result := Result + '.pas'; exit; end; end; end; begin EWE := GetGHTopoDirectory() + DOSSIER_DE_MES_SCRIPTS; ForceDirectoriesUTF8(EWE); TD := TSaveDialog.create(self); try TD.InitialDir := EWE; TD.Options := TD.Options + [ofOverwritePrompt]; TD.Filter := 'Pascal Script (*.pas)|*.pas'; TD.DefaultExt := '.pas'; TD.FileName := getScriptName(); if (TD.Execute) then editPascalScript.Lines.SaveToFile(TD.FileName); finally FreeAndNil(TD); end; end; procedure TCdrPascalScript.btnFindPSFuncClick(Sender: TObject); begin pass; end; procedure TCdrPascalScript.editPascalScriptKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin ;; // KeyPress(Sender, UTF8Key); end; procedure TCdrPascalScript.editPascalScriptUTF8KeyPress(Sender: TObject; var UTF8Key: TUTF8Char); begin ;;// UTF8KeyPress(Sender, UTF8Key); end; procedure TCdrPascalScript.editRecherchePSFuncsKeyPress(Sender: TObject; var Key: char); begin pass; end; procedure TCdrPascalScript.FrameResize(Sender: TObject); var RX: Extended; begin RX := 0.40; PairSplitterside7.Height := self.ClientHeight - 300; PairSplitterSide11.Width := round(self.ClientWidth * RX); end; procedure TCdrPascalScript.acLoadPSScriptExecute(Sender: TObject); var EWE: TStringDirectoryFilename; TD: TOpenDialog; begin EWE := GetGHTopoDirectory() + DOSSIER_DE_MES_SCRIPTS; ForceDirectoriesUTF8(EWE); TD := TOpenDialog.create(self); try TD.InitialDir := EWE; //TD.Options := of; TD.Filter := 'Pascal Script (*.pas)|*.pas'; TD.DefaultExt := '.pas'; if (TD.Execute) then editPascalScript.Lines.LoadFromFile(TD.FileName); finally FreeAndNil(TD); end; end; procedure TCdrPascalScript.acCopyOutputExecute(Sender: TObject); begin editPSOutPut.CopyToClipboard; end; procedure TCdrPascalScript.acClearConsoleInputExecute(Sender: TObject); begin editPSInput.Clear; end; procedure TCdrPascalScript.acClearConsoleErreurExecute(Sender: TObject); begin editPSOutPutError.Clear; end; procedure TCdrPascalScript.acClearConsoleOutputExecute(Sender: TObject); begin editPSOutPut.Clear; end; procedure TCdrPascalScript.acCopyErreurExecute(Sender: TObject); begin editPSOutPutError.CopyToClipboard; end; procedure TCdrPascalScript.acHelpExecute(Sender: TObject); begin DisplayHelpSystem('PASCALSCRIPT'); end; procedure TCdrPascalScript.acNewScriptExecute(Sender: TObject); begin if (GHTopoQuestionOuiNon('Effacer le script courant')) then NewScript(); end; procedure TCdrPascalScript.acPSExecuteExecute(Sender: TObject); var n, i: integer; CompilationOK, ResExec: Boolean; EWE: String; function PreprocessLine(const S: string): string; begin Result := S; // opérateurs du C convertis en opérateurs Pascal Result := StringReplace(Result, '==', '=', [rfReplaceAll]); Result := StringReplace(Result, '!=', '<>', [rfReplaceAll]); Result := StringReplace(Result, '&&', 'AND', [rfReplaceAll]); Result := StringReplace(Result, '||', 'OR', [rfReplaceAll]); // commentaires C Result := StringReplace(Result, '/*', '(*', [rfReplaceAll]); Result := StringReplace(Result, '*/', '*)', [rfReplaceAll]); end; begin PageControlMsgsOutputs.ActivePageIndex := 1; LST_RESULTS_Clear(); // récupérer le script n := editPascalScript.Lines.Count; if (0 = n) then Exit; PSScriptDebugger1.ClearBreakPoints; PSScriptDebugger1.Script.Clear; PSScriptDebugger1.Comp.OnBeforeOutput := psCompilerBeforeOutput; for i := 0 to n - 1 do PSScriptDebugger1.Script.Add(PreprocessLine(editPascalScript.Lines[i])); CompilationOK := PSScriptDebugger1.Compile; n := PSScriptDebugger1.CompilerMessageCount; if (n > 0) then begin for i:= 0 to n - 1 do DispPSCompilerMsg(PSScriptDebugger1.CompilerMessages[i].MessageToString); end; if (CompilationOK) then begin PageControlMsgsOutputs.ActivePageIndex := 2; // aller en ligne 1 de la console d'entrée FConsoleInputCurrentLine := 0; // sauvegarde intermédiaire seulement si le script compile OK //EWE := GetGHTopoDirectory() + DOSSIER_DE_MES_SCRIPTS + '/' + MakeFilenameFromDate('QSaveScript_', Now(), 'pas'); //editPascalScript.Lines.SaveToFile(EWE); ResExec := (PSScriptDebugger1.Exec.RunScript and (PSScriptDebugger1.Exec.ExceptionCode = erNoError)); if (not ResExec) then begin EWE := Format('Run-time error: %d - %s', [PSScriptDebugger1.ExecErrorCode, PSScriptDebugger1.ExecErrorToString]); lsbPSMessages.Items.Add(EWE); end; ShowMessage('Script terminé'); lbStatusPSScript.Caption := 'READY'; lbStatusPSScript.Color := clLime; end else begin PageControlMsgsOutputs.ActivePageIndex := 0; //ShowMessage('Erreur dans le script'); lbStatusPSScript.Caption := 'ERROR'; lbStatusPSScript.Color := clRed; if (PSScriptDebugger1.CompilerMessageCount > 0) then begin for i:= 0 to PSScriptDebugger1.CompilerMessageCount - 1 do DispPSCompilerMsg(PSScriptDebugger1.CompilerErrorToStr(i)); end; lsbPSMessages.ItemIndex := lsbPSMessages.Count - 1; // se positionner au droit de l'erreur editPascalScript.CaretY := PSScriptDebugger1.CompilerMessages[0].Row; editPascalScript.CaretX := PSScriptDebugger1.CompilerMessages[0].Col; editPascalScript.SetFocus; end; end; procedure TCdrPascalScript.acPSStopExecute(Sender: TObject); begin //try // if (PSScriptDebugger1.Exec.) then PSScriptDebugger1.Stop; PSScriptDebugger1.Exec.Pause; PSScriptDebugger1.Exec.Stop; if (not PSScriptDebugger1.Running) then begin DispPSOutput('*******************************'); DispPSOutput('*** Script stopped by user ****'); lbStatusPSScript.Caption := 'READY'; end; //except pass; //end; end; procedure TCdrPascalScript.ListerPSFunctions(); var n, p: LongInt; i, j: Integer; QPSRegProc: TPSRegProc; QPSParameterDecl: TPSParameterDecl; QAT: TbtString; QQ: String; QReturnType: string; ParamName, ParamType: string; begin FOnLineHelpOfFuncs.Clear; n := PSScriptDebugger1.Comp.GetRegProcCount; DispPSOutput(IntToStr(n)); if (n = 0) then Exit; for i := 0 to n - 1 do begin QPSRegProc := PSScriptDebugger1.Comp.GetRegProc(i); QReturnType := ''; // tu peux ajouter QPSRegProc.ReturnType si dispo QAT := Format('%s %s(', [QReturnType, QPSRegProc.Name]); p := QPSRegProc.Decl.ParamCount; for j := 0 to p - 1 do begin QPSParameterDecl := QPSRegProc.Decl.Params[j]; QQ := BoolToStr(j < (p - 1), '; ', ''); // Sécurité maximale : if Assigned(QPSParameterDecl) then begin if Assigned(QPSParameterDecl.aType) then ParamType := LowerCase(QPSParameterDecl.aType.Name) else ParamType := ''; ParamName := LowerCase(QPSParameterDecl.Name); QAT += Format('%s: %s%s', [ParamName, ParamType, QQ]); end else begin QAT += '' + QQ; end; end; QAT += ');'; FOnLineHelpOfFuncs.Add(QAT); end; // Trie et affiche FOnLineHelpOfFuncs.Sort; lsbPSFunctions.Sorted := False; lsbPSFunctions.Clear; for i := 0 to FOnLineHelpOfFuncs.Count - 1 do lsbPSFunctions.Items.Add(FOnLineHelpOfFuncs.Strings[i]); if lsbPSFunctions.Count > 0 then lsbPSFunctions.ItemIndex := 0; end; procedure TCdrPascalScript.DispPSCompilerMsg(const Msg: string); begin lsbPSMessages.Items.Add(msg); lsbPSMessages.ItemIndex := lsbPSMessages.Items.Count - 1; end; procedure TCdrPascalScript.NewScript(const ScriptName: string = 'NewScript01'); const QNameMainProc = 'Main'; //QName_MAX_SIZE_PARAM_ARRAY = 'MAX_SIZE_PARAM_ARRAY'; //QNameTGHStringArray = 'TGHStringArray'; //QGlobalVarSR = 'SR'; begin editPascalScript.Lines.Clear; editPascalScript.Lines.Add(format('program %s;', [ScriptName])); editPascalScript.Lines.Add(format('{ GHTopo Toolbox version %s - PascalScript program - %s }', [GetGHTopoVersion(), DateTimePascalToDateTimeSQL(Now(), False)])); editPascalScript.Lines.Add(format('procedure %s();', [QNameMainProc])); editPascalScript.Lines.Add('var'); editPascalScript.Lines.Add(' i, Nb: integer;'); editPascalScript.Lines.Add('begin'); editPascalScript.Lines.Add(' i := 0;'); editPascalScript.Lines.Add(' Nb := 0;'); editPascalScript.Lines.Add(' (* Your code here *)'); editPascalScript.Lines.Add('end;'); editPascalScript.Lines.Add('(* *************************************** *)'); editPascalScript.Lines.Add('(* Don''t edit after this *)'); editPascalScript.Lines.Add('begin'); editPascalScript.Lines.Add(format(' %s();', [QNameMainProc])); editPascalScript.Lines.Add(' print('''');'); editPascalScript.Lines.Add(' print(''================================'');'); editPascalScript.Lines.Add(' print(''*** Script terminated ***'');'); editPascalScript.Lines.Add('end.'); end; procedure TCdrPascalScript.InitCaptions(); procedure SetAcHint(const ACDC: TAction; const QCaption: string); begin ACDC.Caption := GetResourceString(QCaption); ACDC.Hint := GetResourceString(QCaption); end; begin SetAcHint(acClearConsoleInput , rsTAB_PS_AC_CLEAR_CONSOLE_INPUT); SetAcHint(acClearConsoleOutput, rsTAB_PS_AC_CLEAR_CONSOLE_OUPUT); SetAcHint(acCopyOutput , rsTAB_PS_AC_COPY_OUTPUT); SetAcHint(acPSExecute , rsTAB_PS_AC_RUN); SetAcHint(acPSStop , rsTAB_PS_AC_STOP); SetAcHint(acLoadPSScript , rsTAB_PS_AC_OPEN); SetAcHint(acSavePSScript , rsTAB_PS_AC_SAVE); SetAcHint(acNewScript , rsTAB_PS_AC_NEW); tabShtCompiloMessages.Caption := GetResourceString(rsTAB_PS_TabShtMessagesCompilo_CAPTION); tabShtConsoleInput.Caption := GetResourceString(rsTAB_PS_TabShtConsoleInput_CAPTION); tabShtConsoleOutput.Caption := GetResourceString(rsTAB_PS_TabShtConsoleOutput_CAPTION); tabShtConsoleErreur.Caption := GetResourceString(rsTAB_PS_TabShtConsoleErreur_CAPTION); end; procedure TCdrPascalScript.DispPSOutput(const Msg: string); begin self.editPSOutPut.Lines.add(msg); self.editPSOutPut.CaretY := self.editPSOutPut.Lines.Count - 1; self.editPSOutPut.MoveCaretToVisibleArea; Application.ProcessMessages; end; procedure TCdrPascalScript.DispPSErrOutput(const Msg: string); begin self.editPSOutPutError.Lines.add(msg); self.editPSOutPutError.CaretY := self.editPSOutPutError.Lines.Count - 1; self.editPSOutPutError.MoveCaretToVisibleArea; Application.ProcessMessages; end; function TCdrPascalScript.EvalExpr(const Expr: string; const B: boolean; const nZ: double): double; var Err: Integer; DescErr: string; begin Err := 0; DescErr:= ''; FEvaluateurExpressions.SetModeModulaire(B, nZ); Result := FEvaluateurExpressions.Evaluate(Expr, Err, DescErr); end; procedure TCdrPascalScript.DisplayHelpForProc(const MyProc: TPSRegProc); var p: LongInt; begin memoHelp.Clear; memoHelp.Lines.Add(MyProc.Name); p := MyProc.Decl.ParamCount; end; procedure TCdrPascalScript.ARGV_Clear(); begin FGHStringArray.Redim(); ///for i := low(FGHStringArray) to High(FGHStringArray) do FGHStringArray[i] := ''; end; function TCdrPascalScript.ARGV_GetNthArgAsString(const idx: integer): string; begin //if (IsInRange(Idx, 0, High(FGHStringArray))) then Result := FGHStringArray[idx] else Result := ''; result := FGHStringArray.getString(idx); end; function TCdrPascalScript.ARGV_GetNthArgAsInteger(const idx: integer; const Default: integer): integer; begin Result := FGHStringArray.getInteger(Idx, Default); //StrToIntDef(ARGV_GetNthArgAsString(idx), 0); end; function TCdrPascalScript.ARGV_GetNthArgAsFloat(const idx: integer; const Default: double): double; begin Result := FGHStringArray.getFloat(idx, Default);// ConvertirEnNombreReel(ARGV_GetNthArgAsString(idx), 0.00); end; function TCdrPascalScript.ARGV_LineSplit(const S: string; const Sep: char): boolean; begin Result := false; try FGHStringArray.SplitFrom(S, Sep); // := Split(S, Sep); Result := True; except end; end; function TCdrPascalScript.ARGV_GetNbArgs(): integer; begin result := FGHStringArray.getNbNotNullValues(); //length(FGHStringArray); end; function TCdrPascalScript.ConversionCoordonneesEPSG(const Src, Tgt: integer; const PointInX, PointInY: double; out PointOutX, PointOutY: double): boolean; var PtOut: TProjUV; begin result := false; PointOutX := 0.00; PointOutY := 0.00; try PtOut := FConversionCoords.ConversionSyst1ToSyst2ByCodeEPSG(Src, Tgt, PointInX, PointInY); PointOutX := PtOut.U; PointOutY := PtOut.V; result := true; except end; end; function TCdrPascalScript.ConsoleIsEmpty: boolean; begin Result := (0 = editPSInput.Lines.Count); end; procedure TCdrPascalScript.ClearInputConsole; begin editPSInput.Clear; FConsoleInputCurrentLine := 0; end; procedure TCdrPascalScript.ReadLineCin(out QOutput: string); var Nb: Integer; begin QOutput := ''; Nb := editPSInput.Lines.Count; if (FConsoleInputCurrentLine < Nb) then begin QOutput := editPSInput.Lines.Strings[FConsoleInputCurrentLine]; Inc(FConsoleInputCurrentLine); end; end; procedure TCdrPascalScript.WriteToConsoleIn(const S: string); begin editPSInput.Lines.add(S); FConsoleInputCurrentLine := 0; end; function TCdrPascalScript.ConsoleEOF(): boolean; begin result := (FConsoleInputCurrentLine > (editPSInput.Lines.Count - 1)); end; //////////////////////////////////////////////////////////////////////////////// // wrappers pour fonctions utilitaires // (doivent figurer dans TCdrCalculette en raison de la liste des descripteurs de fichiers procedure TCdrPascalScript.fprint(const Descr: integer; const QLine: string); begin WriteLn(FpTextFiles[Descr], QLine); end; procedure TCdrPascalScript.fprintf(const Descr: integer; const FMT: string; const Argv: array of const); begin WriteLn(FpTextFiles[Descr], Format(FMT, Argv)); end; function TCdrPascalScript.feof(const Descr: integer): boolean; begin Result := EOF(FpTextFiles[Descr]); end; function TCdrPascalScript.freadln(const Descr: integer): string; var QLine: string; begin ReadLn(FpTextFiles[Descr], QLine); result := QLine; end; function TCdrPascalScript.fopen(const Descr: integer; const QFileName: string; const Mode: Char): boolean; begin result := false; try if (not InRange(Descr, Low(FpTextFiles), high(FpTextFiles))) then exit; AssignFile(FpTextFiles[Descr], QFileName); case Mode of 'a': Append(FpTextFiles[Descr]); 'r': Reset(FpTextFiles[Descr]); 'w': ReWrite(FpTextFiles[Descr]); end; result := true; except end; end; procedure TCdrPascalScript.fclose(const Descr: integer); begin try CloseFile(FpTextFiles[Descr]); finally end; end; procedure TCdrPascalScript.fcloseall(); var i: Integer; begin for i := 0 to high(FpTextFiles) do self.fclose(i); end; procedure TCdrPascalScript.ForceDirectory(const Dir: string); begin ForceDirectoriesUTF8(Dir); end; function TCdrPascalScript.GetPathDelimiter(): string; begin Result := PathDelim; end; function TCdrPascalScript.DateTimePascalToSQL(const D: double): string; begin result := DateTimePascalToDateTimeSQL(D); end; function TCdrPascalScript.DateTimeSqlToPascal(const D: string): double; begin result := double(DateTimeSQLToDateTimePascal(D)); end; //////////////////////////////////////////////////////////////////////////////// procedure TCdrPascalScript.cls(); begin editPSOutPut.Clear; end; procedure TCdrPascalScript.clsErr(); begin editPSOutPutError.Clear; end; procedure TCdrPascalScript.DisplaySystemInfos(); const FMT_ECRANS_RESOL = 'Display #%d: %dx%d - %s'; var i, NbMonitors, W, H: Integer; WU: String; DateCompilation: TDateTime; M: TMonitor; YYYY, MM, DD, HH, MN, SS, MS: Word; begin DispPSOutput('System informations:'); DispPSOutput('========================================'); DispPSOutput('Processor:'); DispPSOutput('-----------'); DispPSOutput('Target CPU: ' + {$I %FPCTARGETCPU%}); DispPSOutput(Format('Nb of cores: %d', [GetNbCoresProcessor()])); DispPSOutput(''); NbMonitors := Screen.MonitorCount; DispPSOutput('Display:'); DispPSOutput('----------'); DispPSOutput(Format('%d monitors', [NbMonitors])); for i:= 0 to NbMonitors - 1 do begin M := Screen.Monitors[i]; W := M.Width; H := M.Height; DispPSOutput(Format( FMT_ECRANS_RESOL, [M.MonitorNum,W, H, BoolToStr(M.Primary, 'Primary', 'Auxiliary')])); end; DispPSOutput(''); DispPSOutput('Operating system:'); DispPSOutput('------------------------'); {$IFDEF MSWINDOWS} DispPSOutput(Format('OS: %s', ['Microsoft Windows'])); {$ENDIF} {$IFDEF LINUX} DispPSOutput(Format('OS: %s', ['Linux'])); //TODO: Obtenir la version de Linux {$ENDIF} DispPSOutput(''); DispPSOutput(ApplicationName); DispPSOutput('-------'); DispPSOutput('Target OS: ' + {$I %FPCTARGETOS%}); DateCompilation := FileDateToDateTime(FileAge(ParamStr(0))); DecodeDateTime(DateCompilation, YYYY, MM, DD, HH, MN, SS, MS); DispPSOutput(GetResourceString(rsTYPE_INTERFACE_DESKTOP)); DispPSOutput(GetResourceString(rsCOORDS_CONVERTER_AUTHOR)); DispPSOutput('FPC Compiler: ' + {$I %FPCVERSION%}); WU := 'Compilation: ' + {$I %DATE%} + ' ' + {$I %TIME%}; DispPSOutput(WU); DispPSOutput(''); {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} DispPSOutput('Multithreading: ' + CAPTION_MULTITHREADING(USE_MULTITHREADING)); {$IFDEF USE_METHODE_GRADIENT_CONJUGUE} WU := 'Array of TList, Conjugate gradient method'; {$ELSE} WU := 'Array of arrays of float32, Cholesky method'; {$ENDIF} DispPSOutput('Calculation method: ' + WU); DispPSOutput('OpenGL Viewer: ' + {$IFDEF USE_VIEWER_OPENGL} 'En' {$ELSE} 'Dis' {$ENDIF} + 'abled'); {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} DispPSOutput('========================================'); end; procedure TCdrPascalScript.printf(const FMT: string; const Argv: array of const); begin //self.editPSOutPut.Lines.Add(Format(FMT, Argv)); DispPSOutput(Format(FMT, Argv)); end; procedure TCdrPascalScript.printfErr(const FMT: string; const Argv: array of const); begin DispPSErrOutput(Format(FMT, Argv)); end; //////////////////////////////////////////////////////////////////////////////// // Spécifique GHTopo {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} //****************************************************************************** // Les fiches topo function TCdrPascalScript.BeginListeFichesStations(): boolean; begin result := false; FLesFichesTopo := TFichesTopo.Create; try FLesFichesTopo.Initialiser(FBDDEntites, nil); Result := true; except end; end; procedure TCdrPascalScript.AddFicheStation(const QSr, QSt: integer; const Tag1, Tag2: string); begin FLesFichesTopo.AddStationBySerieStation(QSr, QSt, Tag1, Tag2); end; procedure TCdrPascalScript.ExportFichesToPDF(const QFilename: string; const QCompressed: boolean); begin FLesFichesTopo.ImprimerLesFiches(QFilename, QCompressed); end; function TCdrPascalScript.GetNbFichesStations(): integer; begin Result := FLesFichesTopo.GetNbStations(); end; procedure TCdrPascalScript.EndListeFichesStations(); begin try FLesFichesTopo.Finaliser(); finally FreeAndNil(FLesFichesTopo); end; end; //****************************************************************************** // la BDD topo function TCdrPascalScript.DOCTOPO_GetNbreStationsOfSerieByIdx(const Idx: integer): integer; var SR: TObjSerie; begin SR := FDocuTopo.GetSerie(Idx); Result := SR.NbVisees; end; function TCdrPascalScript.DOCTOPO_GetNbreStationsOfSerieByNoSerie(const NoSerie: integer): integer; var SR: TObjSerie; QIdx: integer; begin if (not FDocuTopo.GetSerieByNumeroSerie(NoSerie, SR, QIdx)) then exit(-1); Result := SR.NbVisees; end; function TCdrPascalScript.DOCTOPO_GetLengthSerieByNoSerie(const NoSerie: integer): double; var SR: TObjSerie; QIdx: integer; begin result := 0.00; if (not FDocuTopo.GetSerieByNumeroSerie(NoSerie, SR, QIdx)) then exit(0.00); result := SR.GetLongueurOfSerie(); end; function TCdrPascalScript.DOCTOPO_GetLengthSerieAtStationByNoSerie(const NoSerie, NoStation: integer): double; var SR: TObjSerie; QIdx: integer; begin result := 0.00; if (not FDocuTopo.GetSerieByNumeroSerie(NoSerie, SR, QIdx)) then exit(0.00); result := SR.GetLongueurOfSerieToStation(NoStation); end; function TCdrPascalScript.DOCTOPO_GetNumeroEtNomDeSerieByIdx(const Idx: integer; out QNumSerie: TNumeroSerie; out QNomSerie: string; out QNbVisees: integer): boolean; var SR: TObjSerie; begin Result := false; SR := FDocuTopo.GetSerie(Idx); try QNumSerie := SR.NumeroDeSerie; QNomSerie := SR.NomSerie; QNbVisees := SR.NbVisees; result := true; except end; end; procedure TCdrPascalScript.DOCTOPO_RemoveSerieByNumSerie(const QNumeroSerie: integer); var SR: TObjSerie; QIdx: integer; begin if (FDocuTopo.GetSerieByNumeroSerie(QNumeroSerie, SR, QIdx)) then FDocuTopo.RemoveSerie(QIdx); DispPSOutput(Format('Série numéro %d supprimée', [QNumeroSerie])); end; procedure TCdrPascalScript.DOCTOPO_RemoveSerieByIdx(const Idx: integer); begin FDocuTopo.RemoveSerie(Idx); DispPSOutput(Format('Série d''index %d supprimée', [Idx])); end; function TCdrPascalScript.DOCTOPO_BeginNewSerie(const QNumeroSerie: integer; const QNoEntrance, QNoReseau: integer; const QSerDep, QPtDep, QSerArr, QPtArr: integer; const QName: string): boolean; var EWE: TNumeroSerie; QInternaIdxSerie: integer; MyVisee: TUneVisee; begin result := false; FCurrentSerieAssigned := false; if (FDocuTopo.GetSerieByNumeroSerie(QNumeroSerie, FCurrentSerie, QInternaIdxSerie)) then begin DispPSOutput(format('*** Série existante: %d - "%s" - Les visées seront ajoutées', [FCurrentSerie.NumeroDeSerie, FCurrentSerie.NomSerie])); FCurrentSerieAssigned := True; result := True; end else begin EWE := IIF(QNumeroSerie < 1, FDocuTopo.getMaxIdxSerie() + 1, QNumeroSerie); DispPSOutput(format('*** Série créée: %d - "%s"', [EWE, QName])); FCurrentSerie := TObjSerie.Create; try FCurrentSerie.ClearStations(); MyVisee.Empty(''); FCurrentSerie.AddVisee(MyVisee); FCurrentSerie.SetNumeroSerie(EWE); FCurrentSerie.SetNomObsSerie(QName, ''); FCurrentSerie.SetChanceObstacle(0, 0); FCurrentSerie.SetNumeroEntranceReseau(QNoEntrance, QNoReseau); FCurrentSerie.SetRaideur(1.00); FCurrentSerie.SetSeriePtDep(QSerDep, QPtDep); FCurrentSerie.SetSeriePtArr(QSerArr, QPtArr); AfficherMessageErreur('DOCTOPO_BeginNewSerie(): QSrArr = %d, QPtArr = %d', [FCurrentSerie.NoSerieArr, FCurrentSerie.NoPointArr]); FCurrentSerieAssigned := True; result := True; except FreeAndNil(FCurrentSerie); end; end; end; function TCdrPascalScript.DOCTOPO_AddNewVisee(const QExpe, QCode: integer; const QTypeVisee, QSecteur: integer; const QLong, QAz, QPente, QLG, QLD, QHZ, QHN: double; const QIDTerrain, QObserv: string): boolean; begin result := false; if (not FCurrentSerieAssigned) then begin DispPSOutput('*** DOCTOPO_BeginNewSerie() non appelé ***'); exit; end; FCurrentSerie.AddVisee(QSecteur, QCode, QExpe, TTypeDeVisee(QTypeVisee), QLong, QAz, QPente, QLG, QLD, QHZ, QHN, QIDTerrain, QObserv, Now(), 0.0, 0.0); end; procedure TCdrPascalScript.DOCTOPO_EndNewSerie(); var QSrArr: TNumeroSerie; QPtArr: TNumeroStation; begin if (not FCurrentSerieAssigned) then begin DispPSOutput('*** DOCTOPO_BeginNewSerie() non appelé ***'); exit; end; QSrArr := FCurrentSerie.NoSerieArr; QPtArr := FCurrentSerie.NoPointArr; AfficherMessageErreur('DOCTOPO_EndNewSerie(): QSrArr = %d, QPtArr = %d', [QSrArr, QPtArr]); if (QSrArr = -1) then FCurrentSerie.SetSeriePtArr(FCurrentSerie.NumeroDeSerie, FCurrentSerie.NbVisees - 1); QSrArr := FCurrentSerie.NoSerieArr; QPtArr := FCurrentSerie.NoPointArr; AfficherMessageErreur('DOCTOPO_EndNewSerie(): QSrArr = %d, QPtArr = %d', [QSrArr, QPtArr]); FDocuTopo.CheckSerie(FCurrentSerie, nil); FDocuTopo.AddSerie(FCurrentSerie); end; procedure TCdrPascalScript.DOCTOPO_AddNewEntrance(const RefSer, RefSt: integer; const XEntree, YEntree, ZEntree: double; const R, G, B: integer; const NomEntree, IDTerrain, Observ: string); var EE: TEntrance; begin EE.eRefSer := RefSer; EE.eRefSt := RefSt; EE.ePosition.setFrom(XEntree, YEntree, ZEntree); EE.eCouleur := RGBToColor(R, G, B); EE.eNomEntree := NomEntree; EE.eIDTerrain := IDTerrain; EE.eObserv := Observ; EE.eFixed := True; FDocuTopo.AddEntrance(EE); end; function TCdrPascalScript.DOCTOPO_ExtractDataForEntranceByIdx(const Idx: integer; out RefSer, RefSt: integer; out XEntree, YEntree, ZEntree: double; out NomEntree: string): boolean; var EE: TEntrance; begin result := false; EE := FDocuTopo.GetEntrance(Idx); XEntree := EE.ePosition.X; YEntree := EE.ePosition.Y; ZEntree := EE.ePosition.Z; RefSer := EE.eRefSer; RefSt := EE.eRefSt; NomEntree := EE.eNomEntree; result := true; end; function TCdrPascalScript.DOCTOPO_ModifyEntrance(const QIdx: integer; const RefSer, RefSt: integer; const XEntree, YEntree, ZEntree: double; const R, G, B: integer; const NomEntree, IDTerrain, Observ: string): boolean; var EE: TEntrance; Nb: Integer; begin result := false; Nb := FDocuTopo.NbEntrances; if (Nb = 0) then Exit; if (QIdx >= Nb) then exit; try EE := FDocuTopo.GetEntrance(QIdx); EE.eRefSer := RefSer; EE.eRefSt := RefSt; EE.ePosition.setFrom(XEntree, YEntree, ZEntree); EE.eCouleur := RGBToColor(R, G, B); EE.eNomEntree := NomEntree; EE.eIDTerrain := IDTerrain; EE.eObserv := Observ; EE.eFixed := true; FDocuTopo.PutEntrance(QIdx, EE); result := True; except end; end; procedure TCdrPascalScript.DOCTOPO_AddNewReseau(const QTypeReseau: integer; const R, G, B: integer; const QNomReseau, QObsReseau: string); var RR: TReseau; begin RR.TypeReseau := QTypeReseau; RR.ColorReseau := RGBToColor(R, G, B); RR.NomReseau := QNomReseau; RR.ObsReseau := QObsReseau; FDocuTopo.AddReseau(RR); end; function TCdrPascalScript.STATION_FindByID(const QID: string; out QSerie: TNumeroSerie; out QStation: TNumeroStation; out QX, QY, QZ: double): boolean; var EE: TBaseStation; begin Result := FBDDEntites.FindStationByCle(false, QID, EE); if (not Result) then exit; QSerie := EE.Entite_Serie; QStation := EE.Entite_Station; QX := EE.PosStation.X; QY := EE.PosStation.Y; QZ := EE.PosStation.Z; end; //****************************************************************************** // La BDD Entités function TCdrPascalScript.STATION_ExtractCoordsFromSerSt(const QSerie: TNumeroSerie; const QStation: TNumeroStation; out QX, QY, QZ: double): boolean; var EE: TBaseStation; begin Result := FBDDEntites.GetEntiteViseeFromSerSt(QSerie, QStation, EE); if (not Result) then exit; QX := EE.PosStation.X; QY := EE.PosStation.Y; QZ := EE.PosStation.Z; end; //****************************************************************************** procedure TCdrPascalScript.LST_Maillages_AddProfil(const ProfilName: string; const X1, Y1, X2, Y2: double; const QCouleur: integer; const QOpacity: byte); begin raise Exception.Create('Fonction non implémentée'); (* QMaillage := FListeMaillages.GetElement(0); if (FMyMaillage.IsValid) then begin WU.SetAttributes(ProfilName, Red(QCouleur), Green(QCouleur), Blue(QCouleur), QOpacity, 1, 0.015); P1.setFrom(X1, Y1); P2.setFrom(X2, Y2); // FMyMaillage.ExtractAndAddProfilTopo(True, P1, P2, WU, ProfilName); end; //*) end; procedure TCdrPascalScript.LST_Maillages_RemoveProfil(const Idx: integer); begin FListeMaillages.RemoveProfilTopo(Idx); end; procedure TCdrPascalScript.LST_Maillages_ClearProfils(); begin FListeMaillages.ClearProfilsTopo(); end; function TCdrPascalScript.LST_Maillages_ExtractBounds(out QX1, QY1, QZ1, QX2, QY2, QZ2: double): boolean; var QMaillage: TMaillage; begin result := false; QMaillage := FListeMaillages.GetElement(0); if (not QMaillage.IsValid) then exit; QX1 := QMaillage.CoinBasGauche.X; QY1 := QMaillage.CoinBasGauche.Y; QZ1 := QMaillage.CoinBasGauche.Z; QX2 := QMaillage.CoinHautDroit.X; QY2 := QMaillage.CoinHautDroit.Y; QZ2 := QMaillage.CoinHautDroit.Z; result := true; end; function TCdrPascalScript.LST_Maillages_ExtractAltitudeFromXY(const QX, QY: double; out QZ: double): boolean; var QMaillage: TMaillage; begin result := false; QMaillage := FListeMaillages.GetElement(0); if (not QMaillage.IsValid) then exit; Result := QMaillage.CalcAltitudeMaillageAtPoint(QX, QY, QZ); end; function TCdrPascalScript.LST_Maillages_GetNbVertexOfMaillage(const Idx: integer): integer; var Nb, QIdx: Integer; M: TMaillage; begin result := 0; Nb := FListeMaillages.GetNbElements(); if (0 = Nb) then exit; QIdx := Idx; if (QIdx > (Nb-1)) then QIdx := Nb-1; if (QIdx < 0) then QIdx := 0; M := FListeMaillages.GetElement(Idx); Result := M.GetNbVertex(); end; function TCdrPascalScript.LST_Maillages_GetNbTrianglesOfMaillage(const Idx: integer): integer; var Nb, QIdx: Integer; M: TMaillage; begin result := 0; Nb := FListeMaillages.GetNbElements(); if (0 = Nb) then exit; QIdx := Idx; if (QIdx > (Nb-1)) then QIdx := Nb-1; if (QIdx < 0) then QIdx := 0; M := FListeMaillages.GetElement(Idx); Result := M.GetNbVertex(); end; procedure TCdrPascalScript.LST_Maillages_UnloadMaillage(const Idx: integer); var Nb, QIdx: Integer; begin Nb := FListeMaillages.GetNbElements(); if (0 = Nb) then exit; QIdx := Idx; if (QIdx > (Nb-1)) then QIdx := Nb-1; if (QIdx < 0) then QIdx := 0; FListeMaillages.RemoveMaillage(QIdx); end; function TCdrPascalScript.LST_Maillages_GenerateSetOfProfilsFromRect(const QNameSet:string; const X1, Y1, X2, Y2, X3, Y3: double; const NbProfilsHorizontaux : integer; const NbProfilsVerticaux : integer; const ColorMinH, ColorMaxH : TColor; const ColorMinV, ColorMaxV : TColor; const Sens : byte): boolean; var Nx, Ny, qdxH, qdyH: double; RectZone: array[0..3] of TPoint2Df; begin result := false; ClosestPointOnLineFromPoint(x1,y1,x2,y2,X3,Y3, Nx, Ny); qdxH := X3 - Nx; qdyH := Y3 - Ny; // Transport du vecteur normal vers l'origine RectZone[0].setFrom(X1, Y1); RectZone[1].setFrom(X2, Y2); RectZone[2].setFrom(X2 + qdxH, Y2 + qdyH); RectZone[3].setFrom(X1 + qdxH, Y1 + qdyH); Result := LST_Maillages_GenerateSetOfProfilsFromQuad(QNameSet, RectZone[0].X, RectZone[0].Y, RectZone[1].X, RectZone[1].Y, RectZone[2].X, RectZone[2].Y, RectZone[3].X, RectZone[3].Y, NbProfilsHorizontaux, NbProfilsVerticaux, ColorMinH, ColorMaxH, ColorMinV, ColorMaxV, Sens); end; function TCdrPascalScript.LST_Maillages_GenerateSetOfProfilsFromQuad(const QNameSet: string; const X1, Y1, X2, Y2, X3, Y3, X4, Y4: double; const NbProfilsHorizontaux : integer; const NbProfilsVerticaux : integer; const ColorMinH, ColorMaxH : TColor; const ColorMinV, ColorMaxV : TColor; const Sens: byte): boolean; var FP1, FP2, FP3, FP4: TPoint2Df; Arete12, Arete14, Arete43, Arete23: TRect2Df; QIdxMax: integer; P: TProfilTopo; EWE: TGHTopoColor; procedure QGenerateProfils(const Prefix: string; const A1, A2: TRect2Df; const ColorMin, ColorMax: TColor; const Nb: Integer); var i: Integer; Extr1, Extr2: TPoint2Df; MyProfilTopo: TProfilTopo; QAT: TLineAttributes; begin //ProgressBar1.Min := 0; //ProgressBar1.Max := Nb - 1; for i := 0 to Nb - 1 do begin //ProgressBar1.Position := i; QAT.SetAttributes(format('%s_%s_', [QNameSet, Prefix]), GetColorDegrade(i, 0, Nb - 1, ColorMin, ColorMax), 192, 1, 0.015); // ou tes couleurs dégradées Extr1 := A1.getPtIntermediaire(i / (Nb - 1)); Extr2 := A2.getPtIntermediaire(i / (Nb - 1)); MyProfilTopo := TProfilTopo.Create; if (MyProfilTopo.Initialiser(Extr1, Extr2)) then begin; FListeMaillages.AddProfilTopo(MyProfilTopo); FListeMaillages.ExtractProfilTraceFromAllMaillages(MyProfilTopo, Extr1, Extr2, QAT, Prefix + i.ToString()); end else raise Exception.Create('Impossible de créer le profil'); Application.ProcessMessages; end; end; begin result := false; FP1.setFrom(X1, Y1); FP2.setFrom(X2, Y2); FP3.setFrom(X3, Y3); FP4.setFrom(X4, Y4); AfficherMsgClass(self, 'LST_Maillages_GenerateSetOfProfilsFromQuad(): %s, %s, %s, %s', [FP1.DebugString('P1'), FP2.DebugString('P2'), FP3.DebugString('P3'), FP4.DebugString('P4')]); // Nouvelle méthode Arete12.setFrom(FP1, FP2); Arete14.setFrom(FP1, FP4); Arete43.setFrom(FP4, FP3); Arete23.setFrom(FP2, FP3); case Sens of 1: // sens ----- begin QGenerateProfils('Sens1', Arete14, Arete23, ColorMinH, ColorMaxH, NbProfilsHorizontaux); end; 2: // sens | | | begin QGenerateProfils('Sens2', Arete12, Arete43, ColorMinV, ColorMaxV, NbProfilsVerticaux); end; 3: // X et Y +-+-+- begin QGenerateProfils('Sens1', Arete14, Arete23, ColorMinH, ColorMaxH, NbProfilsHorizontaux); QGenerateProfils('Sens2', Arete12, Arete43, ColorMinV, ColorMaxV, NbProfilsVerticaux); end; end; if (FListeMaillages.ExtractProfilWithHighestNbConduits(QIdxMax, P)) then begin EWE.setFrom(clGreen, 240); P.LineAttributes.SetAttributes('ProfilMaxNbRecoupes', EWE, 3, 0.35, psSolid); FListeMaillages.PutProfilTopo(QIdxMax, P); end; result := True; end; procedure TCdrPascalScript.LST_Maillages_CheckerAltimetrieEntrees(const DoAdjustAtMNT: boolean; const DeltaZMax: double); var QMaillage: TMaillage; begin QMaillage := FListeMaillages.GetElement(0); if (QMaillage.IsValid) then begin FDocuTopo.CheckerAltimetrieEntrancesByMNT(QMaillage, DoAdjustAtMNT, DeltaZMax); DispPSOutput(Format('MNT_CheckerAltimetrieEntrees(): %.2f', [DeltaZMax])); end else DispPSOutput('*** Maillage invalide ou non chargé ***'); end; procedure TCdrPascalScript.GRAPHE_GenererHTML(const PathStart, PathEnd: string; const Width, Height, MenuWidth: integer; const QNameItineraire: string; const QFilename: string; const QEtendueAutourStation: double = 100.00; const QMapBackgroundColor: integer = clCream; const QMapCenterlineColor: integer = clRed); begin FMyGraphe.ExporterGrapheEnJavascript(QNameItineraire, QFileName, PathStart, PathEnd, TColor(QMapBackgroundColor), //btnBackgroundCarte.ButtonColor, TColor(QMapCenterlineColor), //btnColorCenterline.ButtonColor, QEtendueAutourStation);//, //Width, Height, MenuWidth); end; function TCdrPascalScript.GRAPHE_FindShortestPath(const PathStart, PathEnd, Pathname: string): integer; var EE1, EE2: TBaseStation; Q1, Q2, EWE: Boolean; begin Result := -1; AfficherMsgErrClass(self, 'GRAPHE_FindShortestPath(): %s to %s', [PathStart, PathEnd]); Q1 := FMyGraphe.BDDEntites.FindStationByCle(false, PathStart , EE1); Q2 := FMyGraphe.BDDEntites.FindStationByCle(false, PathEnd , EE2); if (not Q1) then begin ShowMessageFmt('Point de départ %s introuvable', [PathStart]); Exit; end; if (not Q2) then begin ShowMessageFmt('Point d''arrivée %s introuvable', [PathEnd]); Exit; end; FShortestPath.Initialiser(EE1.Entite_Serie, EE1.Entite_Station, EE2.Entite_Serie, EE2.Entite_Station, PathName, clRed); EWE := FMyGraphe.RechercherPlusCourtChemin(FShortestPath); if (EWE) then begin result := FShortestPath.GetNbNoeuds(); end; end; procedure TCdrPascalScript.GRAPHE_ExtractPathNode(const QIdx: integer; out QIDStation: string; out QX, QY, QZ: double); var ND: TAbsoluteIndexCumul; ST: TBZClassNode; begin ND := FShortestPath.GetNoeud(QIdx); ST := FMyGraphe.GetStation(ND.Index); QIDStation := MakeLabelStationFromTIDBaseStation(ST.IDStation); QX := ST.Position.X; QY := ST.Position.Y; QZ := ST.Position.Z; AfficherMessageErreur('%d: %d - %d - %s', [QIdx, ND.Index, ST.IDStation, ST.Position.DebugString('')]); end; procedure TCdrPascalScript.GRAPHE_ExtractNode(const Idx: integer); var ST: TBZClassNode; begin ST := FMyGraphe.GetStation(Idx); AfficherMessageErreur('%d: %d - %s - %s', [Idx, MakeLabelStationFromTIDBaseStation(ST.IDStation), ST.Position.DebugString('')]); end; function TCdrPascalScript.ExtractCoordsOfStation(const QSer: TNumeroSerie; const QSt: TNumeroStation; out QX, QY, QZ: double): boolean; var EE: TBaseStation; begin result := FBDDEntites.GetEntiteViseeFromSerSt(QSer, QSt, EE); if (result) then begin QX := EE.PosStation.X; QY := EE.PosStation.Y; QZ := EE.PosStation.Z; end; end; // LISTE DES MAILLAGES // ================================================ function TCdrPascalScript.LST_Maillages_GetNbMaillages(): integer; begin Result := FListeMaillages.GetNbElements(); end; function TCdrPascalScript.LST_Maillages_GetNomMaillage(const Idx: integer): string; var Nb: Integer; begin Result := 'Not found'; Nb := FListeMaillages.GetNbElements(); if (Idx < Nb) then Result := FListeMaillages.GetElement(Idx).NomDuMaillage; end; function TCdrPascalScript.LST_Maillages_GetNbProfils(): integer; begin Result := FListeMaillages.GetNbProfilsTopo(); end; function TCdrPascalScript.LST_Maillages_LoadMaillageForIdx(const QFilename: string; const Idx: integer): boolean; var Nb, QIdx: Integer; M: TMaillage; B1: Boolean; begin result := false; Nb := FListeMaillages.GetNbElements(); B1 := (0 = Nb); // Il n'y a aucun maillage if (B1) then exit(LST_Maillages_LoadMaillageAndAdd(QFilename)); // Aucun maillage = On crée et on ajoute QIdx := IDX; if (QIdx < 0) then QIdx := 0; // Index négatif = 0n le met à O if (QIdx > (Nb-1)) then QIdx := Nb-1; // Index invalide = On prend le dernier maillage M := FListeMaillages.GetElement(QIdx); // Récupération du maillage Result := M.LoadMaillage(QFilename); // et on le charge end; function TCdrPascalScript.LST_Maillages_LoadMaillageAndAdd(const QFilename: string):boolean; var M: TMaillage; WU: String; begin result := false; M := TMaillage.Create; // On crée un Nouveau maillage: WU := format('Maillage%d', [FListeMaillages.GetNbElements()]); if (M.Initialiser(FBDDEntites, nil, WU)) then begin Result := M.LoadMaillage(QFilename); if (Result) then FListeMaillages.AddElement(M) // Le maillage est valide = On l'ajoute else FreeAndNil(M); // sinon on détruit l'objet nouvellement créé end; end; {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} // Graphisme 2D function TCdrPascalScript.DRAW2D_BeginDrawing(const w, h: integer; const x1, y1, x2, y2: double; const Title: string): boolean; begin result := false; FPSDrawing2D := TdlgDispGraphisme2D.Create(self); try result := FPSDrawing2D.Initialiser(w, h, x1, y1, x2, y2, Title); except FreeAndNil(FPSDrawing2D); end; end; procedure TCdrPascalScript.DRAW2D_EndAndDisplayDrawing(); begin if (Assigned(FPSDrawing2D)) then begin FPSDrawing2D.ShowModal; FreeAndNil(FPSDrawing2D); end; end; procedure TCdrPascalScript.DRAW2D_SetBackgroundColor(const R, G, B, A: byte); begin FPSDrawing2D.SetBackgroundColor(R, G, B, A); end; procedure TCdrPascalScript.DRAW2D_AddLayer(const QLayerName: string; const QAcadIdxColor: integer; const QR, QG, QB, QA: byte); begin FPSDrawing2D.AddLayer(QLayerName, QAcadIdxColor, QR, QG, QB, QA); end; function TCdrPascalScript.DRAW2D_AddStyleSheet(const QStylename: string; const QPenColorR, QPenColorG, QPenColorB, QPenOpacity: byte; const QPenWidtdhInPX: byte; const QPenWidthInMM: double; const QBshColorR, QBshColorG, QBshColorB, QBshOpacity: byte; const QBshStyle: byte; const QFntName: string; const QFntColorR, QFntColorG, QFntColorB, QFntOpacity: byte; const QFntSizeInPX: byte; const QFntSizeInMM: double; const QFntStyle: string): integer; begin Result := FPSDrawing2D.AddStyleSheet(QStylename, QPenColorR, QPenColorG, QPenColorB, QPenOpacity, QPenWidtdhInPX, QPenWidthInMM, QBshColorR, QBshColorG, QBshColorB, QBshOpacity, QBshStyle, QFntName, QFntColorR, QFntColorG, QFntColorB, QFntOpacity, QFntSizeInPX, QFntSizeInMM, QFntStyle); end; procedure TCdrPascalScript.DRAW2D_SetStyleSheet(const Idx: integer); begin FPSDrawing2D.SetStyleSheet(Idx); end; function TCdrPascalScript.DRAW2D_BeginPolyline(const QIdxLayer: integer; const QName: string; const Closed: boolean): boolean; begin Result := FPSDrawing2D.BeginPolyline(QIdxLayer, QName, Closed); end; procedure TCdrPascalScript.DRAW2D_AddVertex(const QX, QY: double); begin FPSDrawing2D.AddVertex(QX, QY); end; procedure TCdrPascalScript.DRAW2D_EndPolyline(); begin FPSDrawing2D.EndPolyline(); end; function TCdrPascalScript.DRAW2D_AddTexte(const QIdxLayer: integer; const QName: string; const QX, QY, AngleOrientation: double; const QAlignment: byte; const Texte: string): boolean; begin //DispPSOutput('*** Layer: ' + QIdxLayer.ToString); Result := FPSDrawing2D.AddTexte(QIdxLayer, QName, QX, QY, AngleOrientation, QAlignment, Texte); end; function TCdrPascalScript.DRAW2D_AddMarker(const QIdxLayer: integer; const QName: string; const QX, QY: double; const QSize, QAlignment: byte; const QCaption: string): boolean; begin //DispPSOutput('*** Layer: ' + QIdxLayer.ToString); result := FPSDrawing2D.AddMarker(QIdxLayer, QName, QX, QY, QSize, QAlignment, QCaption); end; function TCdrPascalScript.DRAW2D_AddImage(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double; const QFilename: string; const QCaption: string): boolean; begin result := FPSDrawing2D.AddImage(QIdxLayer, QName, QX1, QY1, QX2, QY2, QFilename, QCaption); (* AddCalibratedImage(0,0, -20, -50, 100, 120, 'Image1', TD.FileName, 'Image de test'); *); end; function TCdrPascalScript.DRAW2D_AddEllipse(const QIdxLayer: integer; const QName: string; const QX, QY, QR1, QR2: double): boolean; begin result := FPSDrawing2D.AddEllipse(QIdxLayer, QName, QX, QY, QR1, QR2); end; function TCdrPascalScript.DRAW2D_AddRectangle(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double): boolean; begin result := FPSDrawing2D.AddRectangle(QIdxLayer, QName, QX1, QY1, QX2, QY2); end; function TCdrPascalScript.DRAW2D_AddLine(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double): boolean; begin //DispPSOutput('*** Layer: ' + QIdxLayer.ToString); result := FPSDrawing2D.AddLigne(QIdxLayer, QName, QX1, QY1, QX2, QY2); end; function TCdrPascalScript.DRAW2D_AddTriangle(const QIdxLayer: integer; const QName: string; const X1, Y1, X2, Y2, X3, Y3: double): boolean; begin //DispPSOutput('*** Layer: ' + QIdxLayer.ToString); result := FPSDrawing2D.AddTriangle(QIdxLayer, QName, X1, Y1, X2, Y2, X3, Y3); end; // Gestion des vertex indexés // vertex indexés procedure TCdrPascalScript.DRAW2D_BeginListeIndexedVertex; begin FPSDrawing2D.ClearListeIndexedVertex(); end; procedure TCdrPascalScript.DRAW2D_EndListeIndexedVertex; begin FPSDrawing2D.TrierListeIndexedVertex(); end; function TCdrPascalScript.DRAW2D_BeginIndexedPolyline(const QIdxLayer: integer; const QName: string; const Closed: boolean): boolean; begin Result := DRAW2D_BeginPolyline(QIdxLayer, QName, Closed); end; procedure TCdrPascalScript.DRAW2D_AddIndexOfVertex(const Cle: string); var QInternalIdx: integer; QIdentificateur: String; QX, QY, QZ: double; begin QInternalIdx := -1; QIdentificateur := ''; if (FPSDrawing2D.FindIndexedVertexByID(Cle, QInternalIdx, QIdentificateur, QX, QY, QZ)) then DRAW2D_AddVertex(QX, QY); end; procedure TCdrPascalScript.DRAW2D_EndIndexedPolyline; begin DRAW2D_EndPolyline(); end; procedure TCdrPascalScript.DRAW2D_AddIndexedVertex(const QID: string; const QX, QY, QZ: double); begin FPSDrawing2D.AddIndexedVertex(QID, QX, QY, QZ); end; function TCdrPascalScript.DRAW2D_getIndexedVertex(const Idx: integer; out QID: string; out QX, QY, QZ: double): boolean; begin result := FPSDrawing2D.getIndexedVertex(Idx, QID, QX, QY, QZ); end; function TCdrPascalScript.DRAW2D_getNbIndexedVertex: integer; begin result := FPSDrawing2D.getNbIndexedVertex(); end; function TCdrPascalScript.DRAW2D_FindIndexedVertexByID(const QID: string; out QInternalIdx: integer; out QIdentificateur: string; out QX, QY, QZ: double): boolean; begin result := FPSDrawing2D.FindIndexedVertexByID(QID, QInternalIdx, QIdentificateur, QX, QY, QZ); end; function TCdrPascalScript.DRAW2D_AddIndexedTexte(const QIdxLayer: integer; const QName: string; const Cle: string; const QOffsetX, QOffsetY, AngleOrientation: double; const QAlignment: byte; const Texte: string): boolean; var QInternalIdx: Integer; QIdentificateur: String; QX, QY, QZ: double; begin result := false; QInternalIdx := -1; QIdentificateur := ''; if (FPSDrawing2D.FindIndexedVertexByID(Cle, QInternalIdx, QIdentificateur, QX, QY, QZ)) then begin Result := FPSDrawing2D.AddTexte(QIdxLayer, QName, QX + QOffsetX , QY + QOffsetY, AngleOrientation, QAlignment, Texte); end; end; function TCdrPascalScript.DRAW2D_AddIndexedMarker(const QIdxLayer: integer; const QName: string; const Cle: string; const QOffsetX, QOffsetY: double; const QSize, QAlignment: byte; const QCaption: string): boolean; var QInternalIdx: Integer; QIdentificateur: String; QX, QY, QZ: double; begin result := false; QInternalIdx := -1; QIdentificateur := ''; if (FPSDrawing2D.FindIndexedVertexByID(Cle, QInternalIdx, QIdentificateur, QX, QY, QZ)) then begin result := FPSDrawing2D.AddMarker(QIdxLayer, QName, QX + QOffsetX, QY + QOffsetY, QSize, QAlignment, QCaption); end; end; //******************************* //******************************************** //fonctionnalités de téléversement / téléchargement (* Host: ftp4.phpnet.org Port: 21 User: synclinal65 Pwd : ******* LogonType: 1 TimeZone: 0 EncodingType: Auto BypassProxy: 0 //*) function TCdrPascalScript.FTP_BeginConnexion(const QHost: string; const QPort: integer; const QUser, QPassword: string; out QReturnCode: integer; out QReturnMsg: string): boolean; var EWE: String; begin Result := false; EWE := Format('%s.FTP_BeginConnexion()', [self.ClassName]); AfficherMessage(EWE); DispPSOutput(EWE); FTransfertFTP := TRemoteServicesFTP.Create(); try Result := FTransfertFTP.SetParamsAndConnect(QHost, QPort, QUser, QPassword, QReturnCode, QReturnMsg); except end; end; function TCdrPascalScript.FTP_CreateDirectory(const PathFromRoot, QDirectory: TStringDirectoryFilename): boolean; begin Result := FTransfertFTP.CreateDirectory(PathFromRoot, QDirectory); end; procedure TCdrPascalScript.FTP_SetRemoteDirectory(const PathFromRoot: TStringDirectoryFilename); begin FTransfertFTP.SetCurrentRemoteDirectory(PathFromRoot); end; function TCdrPascalScript.FTP_ListFilenamesOf(const Path: string): integer; begin Result := FTransfertFTP.ListFilenamesOf(Path); end; function TCdrPascalScript.FTP_SendFile(const QFilename: string): boolean; var EWE: String; begin EWE := Format('%s.FTP_SendFile(): %s to %s', [self.ClassName, QFilename, FTransfertFTP.GetCurrentRemoteDirectory()]); AfficherMessage(EWE); DispPSOutput(EWE); if (not FileExistsUTF8(QFilename)) then begin DispPSOutput('-- Fichier inexistant: ' + QFilename); exit; end; result := FTransfertFTP.SendFile(QFilename); DispPSOutput('-- Transfert: ' + BoolToStr(result, 'OK', 'KO')); end; function TCdrPascalScript.FTP_GetNbFilesOfLast(): integer; begin Result := FTransfertFTP.GetNbFilesOfLast(); end; function TCdrPascalScript.FTP_GetFileName(const Idx: integer): String; begin Result := FTransfertFTP.GetFileName(Idx); end; procedure TCdrPascalScript.FTP_EndConnexion(); var EWE: string; begin EWE := Format('%s.FTP_EndConnexion()', [ClassName]); AfficherMessage(EWE); DispPSOutput(EWE); try FTransfertFTP.Finaliser(); finally FreeAndNil(FTransfertFTP); end; end; function TCdrPascalScript.EXIF_ExtractPositionAndHorodatage(const MyPhoto: string; out Lat, Lon, Alt: double; out Horodatage: double; out MsgErr: string): boolean; begin result := EXIF_ExtractPositionAndHorodatageOfPhoto(MyPhoto, Lat, Lon, Alt, Horodatage, MsgErr); end; function TCdrPascalScript.FILE_FindFirst(const QPath: string; out QFileFound: string): boolean; begin QFileFound := ''; Result := (0 = FindFirst(QPath, faAnyFile, FSearchRec)); if (NOT(faDirectory = (FSearchRec.Attr AND faDirectory))) then QFileFound := FSearchRec.Name; end; function TCdrPascalScript.FILE_FindNext(out QFileFound: string): boolean; begin QFileFound := ''; Result := (FindNext(FSearchRec) <> 0); if (NOT(faDirectory = (FSearchRec.Attr AND faDirectory))) then QFileFound := FSearchRec.Name; end; procedure TCdrPascalScript.FILE_FindClose(); begin FindClose(FSearchRec); end; //****************************************************************************** // liste de résultats procedure TCdrPascalScript.LST_RESULTS_Clear(); begin FListeResults.Clear; end; procedure TCdrPascalScript.LST_RESULTS_Add(const S: string); begin FListeResults.add(S);; end; function TCdrPascalScript.LST_RESULTS_GetItem(const Idx: integer): string; begin Result := FListeResults.Strings[Idx]; end; function TCdrPascalScript.LST_RESULTS_GetNb(): integer; begin Result := FListeResults.Count; end; function TCdrPascalScript.LST_RESULTS_LoadFromFile(const QFilename: string): integer; var Nb: Integer; begin Nb := 0; AfficherMsgErrClass(self, 'LST_RESULTS_LoadFromFile(): %s', [QFilename]); //try FListeResults.Clear; FListeResults.LoadFromFile(QFilename); Nb := FListeResults.Count; AfficherMessageErreur('%d lines read', [Nb]); //except ;; //end; Result := Nb; end; procedure TCdrPascalScript.LST_RESULTS_SaveToFile(const QFilename: string); begin FListeResults.SaveToFile(QFilename); end; // carte OSM (génération express) function TCdrPascalScript.OSM_InitializeMap(const QFilename, QDocTitle: string): boolean; begin result := FOSMExport.Initialiser(QFilename, QDocTitle, 78, Screen.Height - 220, 43.08, 0.00, false); if (Result) then begin FOSMExport.AddLayer(false, True, 'PonctualPlacemarks', 'Entrances or placemarks', '', '', ssCIRCLE, 10.00, clRed, 0.50); end; end; procedure TCdrPascalScript.OSM_AddLayer(const QLayerIsAMap, QLayerDisplayed: boolean; const QLayerName : string; const QLayerTitle: string; const QLayerAttribution: string; const QURL: String; const QLayerMarkerStyle: integer; const QLayerMarkerSize: double; const QRed, QGreen, QBlue, QOpacity: integer); begin FOSMExport.AddLayer(QLayerIsAMap, QLayerDisplayed, QLayerName, QLayerTitle, QLayerAttribution, QURL, TSymboleStyle( QLayerMarkerStyle), QLayerMarkerSize, RGBToColor(QRed and 255, QGreen and 255, QBlue and 255), QOpacity / 256.00); end; function TCdrPascalScript.OSM_GetNbLayers(): integer; begin Result := FOSMExport.GetNbLayers(); end; procedure TCdrPascalScript.OSM_WriteHeader(); begin FOSMExport.WriteHeader(); end; procedure TCdrPascalScript.OSM_AddPlacemark(const QIdxLayer: integer; const QLat, QLon, QAltitude: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string); var MyLayer: TOSMLayer; QXLambert, QYLambert: double; begin if (QIdxLayer = -1) then MyLayer := FOSMExport.GetLastLayer() else MyLayer := FOSMExport.GetLayer(QIdxLayer); self.ConversionCoordonneesEPSG(CODE_EPSG_WGS84, CODE_EPSG_LAMBERT_93, QLat, QLon, QXLambert, QYLambert); //ConversionCoordonneesIsoleesEPSG(4326, 2154, QLat, QLon, QXLambert, QYLambert); FOSMExport.AddMarker(MyLayer.LayerVarName, QXLambert, QYLambert, QAltitude, QLat, QLon, QEtiquette, QDesignation, QDescription, QObservations, QPhoto); end; procedure TCdrPascalScript.OSM_FinalizeMap(); begin FOSMExport.FlushAllMarkers(); FOSMExport.WriteFooter(); FOSMExport.Finaliser(); end; function TCdrPascalScript.OSM_IdxLayerOf(const QLayerName: string): integer; begin Result := FOSMExport.IdxLayerOf(QLayerName); end; // carte KML (génération express) function TCdrPascalScript.KML_InitializeMap(const QFilename, QDocTitle: string): boolean; begin result := FKMLExport.Initialiser(QFilename, QDocTitle); if (Result) then begin FKMLExport.BeginFolder(2, KML_MAIN_FOLDER); end; end; procedure TCdrPascalScript.KML_BeginFolder(const S: string); begin FKMLExport.BeginFolder(4, S); end; procedure TCdrPascalScript.KML_EndFolder(const S: string); begin FKMLExport.EndFolder(4, S); end; procedure TCdrPascalScript.KML_WriteHeader(); begin pass; end; procedure TCdrPascalScript.KML_AddPlacemark(const QNativeCoordX, QNativeCoordY: double; const QLat, QLon, QAltitude: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string); begin FKMLExport.AddPlacemarkPoint(QNativeCoordX, QNativeCoordY, QAltitude, QLat, QLon, QEtiquette, QDesignation, QDescription, QObservations, QPhoto); end; procedure TCdrPascalScript.KML_FinalizeMap(); begin FKMLExport.EndFolder(2, KML_MAIN_FOLDER); FKMLExport.Finaliser(); end; //****************************************************************************** // dialogues complémentaires function TCdrPascalScript.DLG_DoDialogListBox(const QTitle: string; out QSelectedIndex: integer; out QSelectedItem: string): boolean; begin Result := DoDialogListBox(QTitle, FListeResults, QSelectedIndex, QSelectedItem); end; procedure TCdrPascalScript.SaveLastScript(); var EWE: TStringDirectoryFilename; begin EWE := GetGHTopoDirectory() + MY_LAST_PASCAL_SCRIPT; AfficherMsgClass(self, 'SaveLastScript(): %s', [EWE]); editPascalScript.Lines.SaveToFile(EWE); end; procedure TCdrPascalScript.RetrieveLastScript(); var EWE: TStringDirectoryFilename; begin EWE := GetGHTopoDirectory() + MY_LAST_PASCAL_SCRIPT; AfficherMsgClass(self, 'RetrieveLastScript(): %s', [EWE]); try if (FileExists(EWE)) then editPascalScript.Lines.LoadFromFile(EWE) else NewScript(); except NewScript(); end; end; // Services Web altimétriques IGN function TCdrPascalScript.REST_BeginExtractAltitudes(const IdxAltiRESTServer, IdxAltiDataSRC: integer): boolean; begin result := false; FRESTWebServices := TRESTWebService.Create; try Result := FRESTWebServices.Initialiser(TAltiRESTServer(IdxAltiRESTServer), TAltiDataSRC(IdxAltiDataSRC)); if (Result) then begin Result := FRESTWebServices.POST_BeginListePoints(); end; except end; end; procedure TCdrPascalScript.REST_AddPointByLatLonAlt(const QLat, QLon, QAlt: double); begin FRESTWebServices.AppendPointByLatLonAlt(QLat, QLon, QAlt); end; function TCdrPascalScript.DOCTOPO_GetCurrentEPSG(): integer; begin result := FDocuTopo.GetCodeEPSGSystemeCoordonnees(); end; procedure TCdrPascalScript.REST_AddPointByXYZ(const QX, QY, QZ: double; const CodeEPSG: integer); var PC: TProjUV; begin PC := FConversionCoords.ConversionSyst1ToSyst2ByCodeEPSG(CodeEPSG, CODE_EPSG_WGS84, QX, QY); FRESTWebServices.AppendPointByLatLonAlt(PC.U, PC.V, QZ); end; function TCdrPascalScript.REST_Flush(): integer; begin result := 0; if (FRESTWebServices.POST_Flush()) then Result := FRESTWebServices.POST_TraiterReponse(); end; procedure TCdrPascalScript.REST_EndExtractAltitudes(); begin try FRESTWebServices.Finaliser(); finally FreeAndNil(FRESTWebServices); end; end; function TCdrPascalScript.REST_GetPointLatLonAltAcc(const idx: integer; out QLat, QLon, QAlt, QAcc, QTagFloat: double; out QTagStr: string): boolean; var EWE: TPointLatLonAltAcc; begin result := false; EWE := FRESTWebServices.GetPointATraiter(idx); QLat := EWE.LatitudeOrX; QLon := EWE.LongitudeOrY; QAlt := EWE.AltitudeOrZ; QAcc := EWE.Accuracy; QTagFloat := EWE.TagFloat; QTagStr := EWE.TagStr; result := true; end; function TCdrPascalScript.REST_GetPointXYZAcc(const idx: integer; const CodeEPSG: integer; out QX, QY, QZ, QAcc, QTagFloat: double; out QTagStr: string): boolean; var EWE: TPointLatLonAltAcc; PC: TProjUV; begin result := false; EWE := FRESTWebServices.GetPointATraiter(idx); PC := FConversionCoords.ConversionSyst1ToSyst2ByCodeEPSG(CODE_EPSG_WGS84, CodeEPSG, EWE.LatitudeOrX, EWE.LongitudeOrY); QX := PC.U; QY := PC.V; QZ := EWE.AltitudeOrZ; QAcc := EWE.Accuracy; QTagFloat := EWE.TagFloat; QTagStr := EWE.TagStr; result := true; end; function TCdrPascalScript.REST_ExtractProfilAltimetrique(const Lat1, Lon1, Lat2, Lon2: double; const Sampling: integer): boolean; begin Result := FRESTWebServices.ExtractProfilAltimetrique(Lat1, Lon1, Lat2, Lon2, Sampling, FArrayOfTPointLatLonAltAcc); end; function TCdrPascalScript.REST_GetNbPointsExtraits(): integer; begin result := FRESTWebServices.GetNbPointsExtraits(); end; ///***************************************************************************** // Interrogations SQL (* Exemple: MySQL50Connection1.HostName := '127.0.0.1'; MySQL50Connection1.DatabaseName := 'donneestrafic'; MySQL50Connection1.Password := ''; MySQL50Connection1.UserName := 'root'; //*) function TCdrPascalScript.SQL_Connect(const QHostName, QDatabaseName, QUsername, QPassword: string; const QPort: integer = 3306): boolean; begin result := false; DispPSOutput(Format('-- %s.SQL_Connect: Host: %s Database: %s User: %s', [self.ClassName, QHostName, QDatabaseName, QUsername])); SQLConnector1.ConnectorType:= 'MySQL 5.6'; SQLConnector1.HostName := QHostName; SQLConnector1.DatabaseName := QDatabaseName; SQLConnector1.UserName := QUsername; SQLConnector1.Password := QPassword; SQLConnector1.Connected := True; SQLTransaction1.Database := SQLConnector1; SQLQuery1.Transaction := SQLTransaction1; DataSource1.DataSet := SQLQuery1; Result := SQLConnector1.Connected; end; procedure TCdrPascalScript.SQL_Close(); begin SQLConnector1.Connected := false; end; procedure TCdrPascalScript.SQL_ClearResults(); begin FSQLResults.ClearListe(); end; function TCdrPascalScript.SQL_ExecQuery(const QRequest: string): boolean; var Nb: LongInt; j, i: Integer; QMsg: String; function HasForbiddenKeywords(out Msg: string): boolean; var S: String; function qtest(const KW: string): boolean; begin Result := (Pos(KW + ' ', S) > 0); if (result) then Msg := KW + ' interdit'; end; begin Msg := ''; result := false; S := Uppercase(QRequest); if (qTest('DROP')) then exit(true); if (qTest('TRUNCATE')) then exit(true); if (qTest('ALTER')) then exit(true); if (qTest('UPDATE')) then exit(true); if (qTest('INSERT')) then exit(true); if (qTest('CREATE')) then exit(true); if (qTest('DELETE')) then exit(true); end; begin result := false; FSQLResults.ClearListe(); QMsg := ''; AfficherMsgErrClass(self, 'SQL_ExecQuery: %s', [QRequest]); if (HasForbiddenKeywords(QMsg)) then begin DispPSOutput('-- *** ' + QMsg + ' *** Seules les requêtes de consultation sont autorisées'); Exit(false); end; //AfficherMessageErreur('Requête autorisée'); SQLQuery1.Clear; SQLQuery1.SQL.Clear; SQLQuery1.SQL.Add(QRequest); SQLQuery1.Open(); Nb := 0; while (not SQLQuery1.EOF) do begin FSQLResults.AddEmptyRow(); for j := 0 to SQLQuery1.FieldCount - 1 do FSQLResults.GetLastRow().Add(SQLQuery1.Fields[j].AsString); Nb += 1; SQLQuery1.Next; end; SQLQuery1.Close(); Result := (FSQLResults.GetNbRows() > 0); // contrôle AfficherMessageErreur('%d lignes', [FSQLResults.GetNbRows()]); for i := 0 to FSQLResults.GetNbRows() - 1 do AfficherMessageErreur(FSQLResults.DebugPrintRow(i)); end; function TCdrPascalScript.SQL_Result_GetNbRows(): integer; begin Result := FSQLResults.GetNbRows(); end; function TCdrPascalScript.SQL_Result_GetNbCols(): integer; begin Result := FSQLResults.GetNbColsOfRow(0); end; function TCdrPascalScript.SQL_Result_GetValue(const ARow, ACol: integer): string; begin Result := FSQLResults.GetValue(ARow, ACol); end; procedure TCdrPascalScript.DIRA_TGISLineString_ExtractFromString(const LS: string; const Abscisse: double; out Length: double; out AtAbscisseX, AtAbscisseY: double; out MiddleAbscisseX, MiddleAbscisseY: double); var MyPath: TGISLineString; PPA: TPoint3Df; begin DispPSOutput('DIRA_TGISLineString_ExtractFromString'); Length := 0.00; AtAbscisseX := 0.00; AtAbscisseY := 0.00; MiddleAbscisseX := 0.00; MiddleAbscisseY := 0.00; MyPath := TGISLineString.Create('Path001'); try if (MyPath.DecodeQGISLineString(LS)) then begin Length := MyPath.PathLength(); PPA := MyPath.PositionXYZForAbscisse(Abscisse); AtAbscisseX := PPA.X; AtAbscisseY := PPA.Y; PPA := MyPath.PositionXYZMiParcours(); MiddleAbscisseX := PPA.X; MiddleAbscisseY := PPA.Y; end; MyPath.ClearListe(); finally FreeAndNil(MyPath); end; end; {$IFDEF GHTOPO_SIMPLIFIE} function TCdrPascalScript.BRIC4_ExtractFromDatagram(const D: string; out Horodatage: string; out Long, Azimut, Pente: single): boolean; var DT: TBRIC4_ArrayOfBytes; H: TDateTime; begin result := false; DT.setFromDatagramAsText(D); DT.toMesureLAPHorodatee(H, Long, Azimut, Pente); AfficherMessageErreur('%f, %f, %f',[Long, Azimut, Pente]); Horodatage := DateTimePascalToSQL(H); result := (Long > 0.00); end; function TCdrPascalScript.BRIC4_MakeStrDatagramFromMesureLAPHorodatee(const Horodatage: string; const Long, Azimut, Pente: single): string; var DT: TBRIC4_ArrayOfBytes; H: TDateTime; begin H := DateTimeSQLToDateTimePascal(Horodatage); DT.setBytesFromMesureLAPHorodatee(H, Long, Azimut, Pente); result := DT.DataToHex(); end; {$endif GHTOPO_SIMPLIFIE} procedure TCdrPascalScript.ARR_XYZ_Redim(const Nb: integer); begin FArrayOfTPointLatLonAltAcc.Redim(Nb); end; function TCdrPascalScript.ARR_XYZ_GetNbElements: integer; begin Result := FArrayOfTPointLatLonAltAcc.getNbElements(); end; procedure TCdrPascalScript.ARR_XYZ_AppendFrom(const Lat, Lon, Alt, Acc, TagFloat: double; const QTag: string); begin FArrayOfTPointLatLonAltAcc.AppendFrom(Lat, Lon, Alt, Acc, TagFloat, QTag); end; procedure TCdrPascalScript.ARR_XYZ_GetFrom(const Idx: integer; out Lat, Lon, Alt, Acc, TagFloat: double; out Tag: string); var P: TPointLatLonAltAcc; begin P := FArrayOfTPointLatLonAltAcc.GetElement(Idx); Lat := P.LatitudeOrX; Lon := P.LongitudeOrY; Alt := P.AltitudeOrZ; Acc := P.Accuracy; Tag := P.TagStr; TagFloat := P.TagFloat; end; procedure TCdrPascalScript.ARR_XYZ_GetBounds(out CX1, CY1, CZ1, CX2, CY2, CZ2: double); begin CX1 := FArrayOfTPointLatLonAltAcc.BoundingBox.X1; CY1 := FArrayOfTPointLatLonAltAcc.BoundingBox.Y1; CZ1 := FArrayOfTPointLatLonAltAcc.BoundingBox.Z1; CX2 := FArrayOfTPointLatLonAltAcc.BoundingBox.X2; CY2 := FArrayOfTPointLatLonAltAcc.BoundingBox.Y2; CZ2 := FArrayOfTPointLatLonAltAcc.BoundingBox.Z2; end; procedure TCdrPascalScript.ARR_XYZ_AddBoundingBoxMargin(const M: double); begin FArrayOfTPointLatLonAltAcc.BoundingBox.AddMarge(M); end; // BinHex function TCdrPascalScript.BINHEX_Open(): boolean; begin result := false; FListeResults.Clear; result := true; end; procedure TCdrPascalScript.BINHEX_SendString(const S: string); begin FListeResults.Add(S); end; function TCdrPascalScript.BINHEX_SaveToHex(const QFilename, Description: string): boolean; var QFileTmp: String; FBinHex: TBinHexUtils; begin result := false; QFileTmp := '_tmp.dat'; FListeResults.SaveToFile(QFileTmp); FBinHex := TBinHexUtils.Create; try Result := FBinHex.Initialiser(QFileTmp); if (FBinHex.Zip()) then FBinHex.toFileHex(QFilename, Description); FBinHex.Finaliser(); finally FreeAndNil(FBinHex); end; FListeResults.Clear; end; function TCdrPascalScript.BINHEX_LoadFromHex(const QFilename: string): integer; var FBinHex: TBinHexUtils; QErrMSG, QFileZipTmp: string; QStream: TStream; begin Result := 0; QFileZipTmp := '_tmp.zip'; FListeResults.Clear; FBinHex := TBinHexUtils.Create; try if (FBinHex.Initialiser(QFilename)) then begin if (FBinHex.LoadFromHex(QFilename, QErrMSG)) then begin FBinHex.toFileZip(QFileZipTmp); FBinHex.UnzipFile(QFileZipTmp, QStream); FListeResults.LoadFromStream(QStream); FreeandNil(QStream); Result := FListeResults.Count; end; end; FBinHex.Finaliser(); finally FreeAndNil(FBinHex); end; end; procedure TCdrPascalScript.SMTP_BeginTransaction(const ASubject: string); begin AfficherMsgClass(self, 'SMTP_BeginTransaction: Host %s, Port: %s, User: %s', [FSMTPHost, FSMTPPort, FSMTPUserName]); FListeResults.Clear; FAttachments.Clear; FListeResults.Add(ASubject); end; procedure TCdrPascalScript.SMTP_AddLine(const S: string); begin FListeResults.Add(S); end; procedure TCdrPascalScript.SMTP_AddAttachment(const S: string); begin pass; //FAttachments.Add(S);; end; procedure TCdrPascalScript.SMTP_EndTransactionAndSend(const ATo: string); var QSubject: String; Nb, i: Integer; begin try QSubject := FListeResults.Strings[0]; FListeResults.Delete(0); FListeResults.add('======================='); Nb := FAttachments.count; if (nb > 0) then begin for i := 0 to Nb-1 do FListeResults.add(' ' + FAttachments.Strings[i]); end; FListeResults.add(format('%d attachments', [Nb])); FListeResults.add(''); FListeResults.Add('Sent by GHTopo Pascal Script'); SendAMessage(0, FSMTPHost, FSMTPPort, FSMTPUserName, FSMTPPassWord, FSMTPUserName, ATo, QSubject, FListeResults, FAttachments); FListeResults.Clear; FAttachments.Clear; finally end; end; function TCdrPascalScript.OSM_MAP_WIND_Create(const CodeEPSG: integer; const QX, QY: double): boolean; begin result := false; FdlgVueCarte := TdlgVueCarte.Create(self); try result := FdlgVueCarte.Initialiser(FConversionCoords, TCodeEPSG(CodeEPSG), QX, QY); except end; end; procedure TCdrPascalScript.OSM_MAP_WIND_AddLayer(const QLayerName: string; const QOpacity: single); begin FdlgVueCarte.AddLayer(QLayerName, QOpacity); end; procedure TCdrPascalScript.OSM_MAP_WIND_SetCurrentLayerByIdx(const QIdx: integer); begin FdlgVueCarte.SetCurrentLayerByIdx(QIdx); end; procedure TCdrPascalScript.OSM_MAP_WIND_SetCurrentLayerByName(const QLayerName: string); begin FdlgVueCarte.SetCurrentLayerByName(QLayerName); end; procedure TCdrPascalScript.OSM_MAP_WIND_AddPoint(const QX, QY, QZ: double; const QLabel: string); begin FdlgVueCarte.AddPoint(QX, QY, QZ, QLabel); end; function TCdrPascalScript.OSM_MAP_WIND_BeginPolyLine(): boolean; begin Result := FdlgVueCarte.BeginPolyLine(); end; function TCdrPascalScript.OSM_MAP_WIND_BeginPolygone(): boolean; begin Result := FdlgVueCarte.BeginPolygone(); end; procedure TCdrPascalScript.OSM_MAP_WIND_AddVertex(const QX, QY, QZ: double); begin FdlgVueCarte.AddVertex(QX, QY, QZ); end; procedure TCdrPascalScript.OSM_MAP_WIND_EndPolyLine(const LR, LG, LB, LA: byte; const LineWidth: double); var LC: TGHTopoColor; begin LC.setFrom(LR, LG, LB, LA); FdlgVueCarte.EndPolyLine(LC, LineWidth); end; procedure TCdrPascalScript.OSM_MAP_WIND_EndPolygone(const LR, LG, LB, LA: byte; const BR, BG, BB, BA: byte; const LineWidth: double); var LC, BC: TGHTopoColor; begin LC.setFrom(LR, LG, LB, LA); BC.setFrom(BR, BG, BB, BA); FdlgVueCarte.EndPolygone(LC, BC, LineWidth); end; procedure TCdrPascalScript.OSM_MAP_WIND_Display(); begin if (not assigned(FdlgVueCarte)) then exit; try FdlgVueCarte.ShowModal; FdlgVueCarte.Finaliser(); finally FreeAndNil(FdlgVueCarte); end; end; function TCdrPascalScript.PALETTE_256_GetColorByIndex(const Idx: integer; out LR, LG, LB, LA: byte): boolean; var C: TGHTopoColor; begin result := false; try C := FPalette256.GetColorByIndex(TIdxCouleur(Idx)); LR := C.Red; LG := C.Green; LB := C.Blue; LA := C.Alpha; except pass; // En attente, non bloquant end; end; function TCdrPascalScript.PALETTE_256_GetIdxNearestColor(const LR, LG, LB, LA: byte): integer; var C: TGHTopoColor; begin try C.setFrom(LR, LG, LB, LA); Result := FPalette256.GetIdxNearestColor(C); except pass; // En attente, non bloquant end; end; end. //****************************************************************************** (* procedure TCdrPascalScript.RecenserAdditionalProcs(Sender: TPSScriptDebugger); var EWE: String; begin DefineTypesAndRecords(); // TODO Ici ou dans Initialise() ?; sender.AddFunction(@pass , 'procedure pass;'); sender.AddFunction(@GetGHTopoVersion , 'function GetGHTopoVersion(): string;'); sender.AddFunction(@GetGHTopoDirectory , 'function GetGHTopoDirectory(): string'); sender.AddFunction(@FileExists , 'function FileExists(const NF: string): boolean;'); sender.AddFunction(@ExtractFileExt , 'function ExtractFileExt(const FileName: string): string;'); sender.AddFunction(@ExtractFileName , 'function ExtractFileName(const FileName: string): string;'); sender.AddFunction(@GetGUID , 'function GetGUID(): string;'); sender.AddFunction(@IntegerToXLSColumn , 'function IntegerToXLSColumn(const Value: integer): string;'); sender.AddFunction(@XLSColumnToInteger , 'function XLSColumnToInteger(const Value: string): integer;'); sender.AddFunction(@RandomBetweenValuesInMeters, 'function RandomBetweenValuesInMeters(const V1, V2: double): double;'); sender.AddFunction(@Format , 'function format(Const Fmt : String; const Args : Array of const) : String;'); sender.AddFunction(@Format , 'function sprintf(Const Fmt : String; const Args : Array of const) : String;'); sender.AddFunction(@KMLColor , 'function KMLColor(const R, G, B, A: byte): string;'); sender.AddFunction(@Graphics.RGBToColor , 'function RGB(const R, G, B: byte): Longint'); sender.AddFunction(@GetColorDegrade , 'function GetColorDegrade(const z, zmin, zmax: Double; const Coul1, Coul2: LongInt): LongInt'); //sender.AddFunction(@ConversionCoordonneesIsoleesEPSG, 'function ConversionCoordonneesIsoleesEPSG(const Src, Tgt: integer; const PointInX, PointInY: double; out PointOutX, PointOutY: double): boolean;'); sender.AddFunction(@ConvertirEnNombreReel , 'function StrToFloatDef(const S: string; const Default: double): double;'); sender.AddFunction(@FormatterIDTerrainStation, 'function FormatterIDTerrainStation(const S: string): string;'); sender.AddFunction(@CalculerDeclinaisonMagnetique, 'function CalculerDeclinaisonMagnetique(const Lat, Lon, Alt: double; const YYYY, MM, DD: word): double;'); sender.AddFunction(@CalculerDeclinaisonMagnetiqueFromREST, 'function CalculerDeclinaisonMagnetiqueFromREST(const Lat, Lon, Alt: double; const YYYY, MM, DD: word): double;'); // boites de dialogue sender.AddFunction(@ShowMessage , 'procedure ShowMessage(const msg: string);'); sender.AddFunction(@ShowMessage , 'procedure MsgBox(const msg: string);'); sender.AddFunction(@GHTopoQuestionOuiNon , 'function QuestionOuiNon(const Msg: string): boolean;'); sender.AddFunction(@GHTopoInputQuery , 'function InputQuery(const ACaption, APrompt: string; var QValeur: string): boolean;'); sender.AddFunction(@GHTopoInputPasswordQuery , 'function InputPasswordQuery(const ACaption, APrompt: string; var QPWD: string): boolean;'); sender.AddFunction(@DoDialogSaveFile , 'function DialogSaveFile(const QFilter: string; const QDefaultExt: string; var QFileName: string; out idxFilter: integer): boolean;'); sender.AddFunction(@DoDialogOpenFile , 'function DialogOpenFile(const QFilter: string; const QDefaultExt: string; var QFileName: string): boolean;'); sender.AddFunction(@SelectionCouleurToporobot, 'function SelectionCouleurToporobot(const OldIdx: integer): Integer;'); sender.AddFunction(@DoDialogSelectDirectory , 'function DialogSelectDirectory(const QDialogTitle: string; var QDirectory: string): boolean;'); sender.AddFunction(@SelectColor , 'function DialogSelectColor(): string;'); // fonctions math additionnelles : certaines fonctions ne sont pas acceptées telles quelles sender.AddFunction(@tan , 'function tan(x : double) : double;'); // added by JPC sender.AddFunction(@arcsin , 'function arcsin(x : double) : double;'); // added by JPC sender.AddFunction(@arccos , 'function arccos(x : double) : double;'); // added by JPC sender.AddFunction(@farctan , 'Function arctan(x : double) : double;'); // added by JPC sender.AddFunction(@farctan2 , 'Function arctan2(y, x : double) : double;'); // added by JPC sender.AddFunction(@sinh , 'Function sinh(x : double) : double;'); // added by JPC sender.AddFunction(@cosh , 'Function cosh(x : double) : double;'); // added by JPC sender.AddFunction(@tanh , 'Function tanh(x : double) : double;'); // added by JPC sender.AddFunction(@fexp , 'function exp(x : double) : double;'); sender.AddFunction(@fln , 'function ln(x : double) : double;'); sender.AddFunction(@flog , 'function log(x : double) : double;'); {$IFNDEF RASPBERRY_PI} // FPC pour ARM ne propose pas ces fonctions sender.AddFunction(@floor64 , 'function floor(x : double) : Int64;'); sender.AddFunction(@ceil64 , 'function ceil(x : double) : Int64;'); {$ENDIF} sender.AddFunction(@fabs , 'function fabs(x : double) : double;'); sender.AddFunction(@power , 'function power(const X, Y: double): double;'); sender.AddFunction(@power , 'function pow(const X, Y: double): double;'); sender.AddFunction(@radtodeg , 'function radtodeg(x : double) : double;'); sender.AddFunction(@degtorad , 'function degtorad(x : double) : double;'); sender.AddFunction(@radtograd , 'function radtograd(x : double) : double;'); sender.AddFunction(@gradtorad , 'function gradtorad(x : double) : double;'); sender.AddFunction(@degtograd , 'function degtograd(x : double) : double;'); sender.AddFunction(@gradtodeg , 'function gradtodeg(x : double) : double;'); sender.AddFunction(@DegMinSec2DegDec , 'function DegMinSec2DegDec(const S: string): double;'); // trigo en degrés sender.AddFunction(@sind , 'function sind(x : double) : double;'); sender.AddFunction(@cosd , 'function cosd(x : double) : double;'); sender.AddFunction(@tand , 'function tand(x : double) : double;'); // trigo en grades sender.AddFunction(@sing , 'function sing(x : double) : double;'); sender.AddFunction(@cosg , 'function cosg(x : double) : double;'); sender.AddFunction(@tang , 'function tang(x : double) : double;'); sender.AddFunction(@Now , 'function Now(): double;'); sender.AddFunction(@Now , 'function Maintenant(): double;'); sender.addfunction(@LLANFAIR_PG , 'function llanfairpg(): string;'); //sender.AddFunction(@DateTimePascalToDateTimeSQL , 'function DateTimePascalToDateTimeSQL(const MyDate: double): string;'); //sender.AddFunction(@DateTimeSQLToDateTimePascal , 'function DateTimeSQLToDateTimePascal(const MyDateSQL: string): double;'); sender.AddFunction(@ConvertirEnNombreReel , 'function ConvertirEnNombreReel(const S: string; const Default: Extended): Extended'); sender.AddFunction(@FormatterNombreOOo , 'function FormatterNombreOOo(const Value: Double; const NbDecs: integer; const IgnoreNulls: boolean): string;'); sender.AddFunction(@Hypot2D , 'function Hypot2D(const DX, DY: Double): Double;'); sender.AddFunction(@Hypot3D , 'function Hypot3D(const DX, DY, DZ: Double): Double;'); sender.AddFunction(@GetAzimut , 'function GetAzimut(const dx, dy: double; const Unite: double): double;'); sender.AddFunction(@ConvertirEnFiltreSeries , 'function ConvertirEnFiltreSeries(const S: string): string;'); // pour matching dans les recherches -- TODO: Support des Expressions régulières sender.AddFunction(@CalcDistanceJaroWinkler , 'function CalcDistanceJaroWinkler(const S1, S2: string): double;'); sender.AddFunction(@CalcDistanceDamerauLevenshtein, 'function CalcDistanceDamerauLevenshtein(const S1, S2: string): integer;'); sender.AddFunction(@InStr , 'function InStr(const Str, FindWhat: string; const CaseSensitive: boolean): integer;'); sender.AddFunction(@ContainsSubStr , 'function ContainsSubStr(const Str, FindWhat: string; const CaseSensitive: boolean): boolean;'); // résolution d'équations sender.AddFunction(@SolveEquationDegre1, 'function SolveEquationDegre1(const a, b: double; out X1: double): boolean;'); sender.AddFunction(@SolveEquationDegre2, 'function SolveEquationDegre2(const a, b, c: double; out X1, X2: double): boolean;'); sender.AddFunction(@SolveEquationDegre3, 'function SolveEquationDegre3(const a, b, c, d: double; out X1, X2, X3: double; out Delta: double): boolean;'); // Transmission des gisements sender.AddFunction(@TransmissionGisement, 'function TransmissionGisement(const QGisementPrecedent, QLectureArriere, QLectureAvant: double): double;'); // EPSG sender.AddMethod(self, @TCdrPascalScript.DOCTOPO_GetCurrentEPSG , 'function DOCTOPO_GetCurrentEPSG(): integer;'); // pour extraction d'altitudes IGN (service Web) sender.AddFunction(@GetAltitudeByWebServiceIGN , 'function GetAltitudeByWebServiceIGN(const QLat, QLon: double; out QAltitude, QAccuracy: double): integer;'); sender.AddFunction(@GetAltitudeByWebServiceOSM , 'function GetAltitudeByWebServiceOSM(const QLat, QLon: double; out QAltitude, QAccuracy: double): integer;'); sender.AddMethod(self, @TCdrPascalScript.REST_BeginExtractAltitudes, 'function REST_BeginExtractAltitudes(const IdxAltiRESTServer, IdxAltiDataSRC: integer): boolean;'); sender.AddMethod(self, @TCdrPascalScript.REST_AddPointByLatLonAlt , 'procedure REST_AddPointByLatLonAlt(const QLat, QLon, QAlt: double);'); sender.AddMethod(self, @TCdrPascalScript.REST_AddPointByXYZ , 'procedure REST_AddPointByXYZ(const QX, QY, QZ: double; const CodeEPSG: integer);'); sender.AddMethod(self, @TCdrPascalScript.REST_Flush , 'function REST_Flush(): integer;'); sender.AddMethod(self, @TCdrPascalScript.REST_EndExtractAltitudes , 'procedure REST_EndExtractAltitudes();'); sender.AddMethod(self, @TCdrPascalScript.REST_GetPointLatLonAltAcc , 'function REST_GetPointLatLonAltAcc(const idx: integer; out QLat, QLon, QAlt, QAcc, QTagFloat: double; out QTag: string): boolean;'); sender.AddMethod(self, @TCdrPascalScript.REST_GetNbPointsExtraits , 'function REST_GetNbPointsExtraits(): integer;'); sender.AddMethod(self, @TCdrPascalScript.REST_GetPointXYZAcc , 'function REST_GetPointXYZAcc(const idx: integer; const CodeEPSG: integer; out QX, QY, QZ, QAcc, QTagFloat: double; out QTag: string): boolean;'); sender.AddMethod(self, @TCdrPascalScript.REST_ExtractProfilAltimetrique, 'function REST_ExtractProfilAltimetrique(const Lat1, Lon1, Lat2, Lon2: double; const Sampling: integer): boolean;'); //sender.AddMethod(self, @ , ''); //sender.AddMethod(self, @ , ''); // infos système (mémoire, proc, HDD, etc ...); sender.AddMethod(self, @TCdrPascalScript.DisplaySystemInfos, 'procedure DisplaySystemInfos();'); // évaluation d'expressions sender.AddMethod(self, @TCdrPascalScript.EvalExpr , 'function Eval(const Expr: string; const B: boolean; const nZ: double): double;'); // //'function Eval(const Expr: string): double;'); // ces fonctions utilisent des variables privées de TCdrPascalScript; sender.AddMethod(self, @TCdrPascalScript.DispPSOutput, 'procedure print(const Msg: string);'); sender.AddMethod(self, @TCdrPascalScript.DispPSOutput, 'procedure WriteLn(const Msg: string);'); sender.AddMethod(self, @TCdrPascalScript.DispPSOutput, 'procedure cout(const Msg: string);'); sender.AddMethod(self, @TCdrPascalScript.printf , 'procedure printf(const Fmt : String; const Args : Array of const): String;'); sender.AddMethod(self, @TCdrPascalScript.feof , 'function feof(const Descr: integer): boolean;'); sender.AddMethod(self, @TCdrPascalScript.fopen , 'function fopen(const Descr: integer; const QFileName: string; const Mode: Char): boolean;'); sender.AddMethod(self, @TCdrPascalScript.fprint , 'procedure fwriteln(const Descr: integer; const QLine: string);'); sender.AddMethod(self, @TCdrPascalScript.fprintf , 'procedure fprintf(const Descr: integer; const FMT: string; const Args: array of const);'); sender.AddMethod(self, @TCdrPascalScript.freadln , 'function freadln(const Descr: integer): string;'); sender.AddMethod(self, @TCdrPascalScript.fclose , 'procedure fclose(const Descr: integer)'); sender.AddMethod(self, @TCdrPascalScript.fcloseall , 'procedure fcloseall()'); sender.AddMethod(self, @TCdrPascalScript.cls , 'procedure cls()'); sender.AddMethod(self, @TCdrPascalScript.cls , 'procedure ClrScr()'); sender.AddMethod(self, @TCdrPascalScript.ForceDirectory , 'procedure ForceDirectory(const Dir: string);'); sender.AddMethod(self, @TCdrPascalScript.GetPathDelimiter, 'function GetPathDelimiter(): string;'); sender.AddMethod(self, @TCdrPascalScript.GetPathDelimiter, 'function PathDelim(): string;'); {$ifdef TOOLBOX_EMBEDDED_IN_GHTOPO} sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNomEtude , 'function DOCTOPO_GetNomEtude(): string;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbSeries , 'function DOCTOPO_GetNbSeries(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbEntrances , 'function DOCTOPO_GetNbEntrees(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbReseaux , 'function DOCTOPO_GetNbReseaux(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbExpes , 'function DOCTOPO_GetNbExpes(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbCodes , 'function DOCTOPO_GetNbCodes(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbSecteurs , 'function DOCTOPO_GetNbSecteurs(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.GetNbAntennes , 'function DOCTOPO_GetNbAntennes(): integer;'); sender.AddMethod(FDocuTopo, @TToporobotStructure2012.CheckerLesDonneesTopo , 'procedure DOCTOPO_CheckerLesDonneesTopo();'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_GetNbreStationsOfSerieByIdx , 'function DOCTOPO_GetNbStationsOfSerieByIdx(const Idx: integer): integer;'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_GetNbreStationsOfSerieByNoSerie , 'function DOCTOPO_GetNbStationsOfSerieByNoSerie(const NumeroSerie: integer): integer;'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_GetNumeroEtNomDeSerieByIdx , 'function DOCTOPO_GetNumeroEtNomDeSerieByIdx(const Idx: integer; out QNumSerie: integer; out QNomSerie: string; out QNbVisees: integer): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_GetLengthSerieByNoSerie , 'function DOCTOPO_GetLengthSerieByNoSerie(const NoSerie: integer): double;'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_GetLengthSerieAtStationByNoSerie, 'function DOCTOPO_GetLengthSerieAtStationByNoSerie(const NoSerie, NoStation: integer): double;'); EWE := 'function DOCTOPO_BeginNewSerie(const QNumeroSerie: integer; ' + 'const QNoEntrance, QNoReseau: integer; ' + 'const QSerDep, QPtDep, QSerArr, QPtArr: integer; ' + 'const QName: string): boolean;'; sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_BeginNewSerie , EWE); EWE := 'function DOCTOPO_AddNewVisee(const QExpe, QCode: integer; ' + 'const QTypeVisee, QSecteur: integer; ' + 'const QLong, QAz, QPente, QLG, QLD, QHZ, QHN: double; ' + 'const QIDTerrain, QObserv: string): boolean;'; sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_AddNewVisee , EWE); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_EndNewSerie , 'procedure DOCTOPO_EndNewSerie();'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_RemoveSerieByNumSerie , 'procedure DOCTOPO_RemoveSerieByNumSerie(const QNumeroSerie: integer);'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_RemoveSerieByIdx , 'procedure DOCTOPO_RemoveSerieByIdx(const Idx: integer);'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_AddNewEntrance , 'procedure DOCTOPO_AddNewEntrance(const RefSer, RefSt: integer; const XEntree, YEntree, ZEntree: double; const R, G, B: integer; const NomEntree, IDTerrain, Observ: string);'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_ExtractDataForEntranceByIdx , 'function DOCTOPO_ExtractDataForEntranceByIdx(const Idx: integer; out RefSer, RefSt: integer; out XEntree, YEntree, ZEntree: double; out NomEntree: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_ModifyEntrance , 'function DOCTOPO_ModifyEntrance(const QIdx: integer; const RefSer, RefSt: integer; const XEntree, YEntree, ZEntree: double; const R, G, B: integer; const NomEntree, IDTerrain, Observ: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DOCTOPO_AddNewReseau , 'procedure DOCTOPO_AddNewReseau(const QTypeReseau: integer; const R, G, B: integer; const QNomReseau, QObsReseau: string); '); // BDD entités sender.AddMethod(self , @TCdrPascalScript.STATION_ExtractCoordsFromSerSt , 'function STATION_ExtractCoordsFromSerSt(const QSerie, QStation: integer; out QX, QY, QZ: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.STATION_FindByID , 'function STATION_FindByID(const QID: string; out QSerie, QStation: integer; out QX, QY, QZ: double): boolean;'); // fiches PDF de stations sender.AddMethod(self , @TCdrPascalScript.BeginListeFichesStations , 'function BeginListeFichesStations(): boolean;'); sender.AddMethod(self , @TCdrPascalScript.AddFicheStation , 'procedure AddFicheStation(const QSr, QSt: integer; const Tag1, Tag2: string);'); sender.AddMethod(self , @TCdrPascalScript.GetNbFichesStations , 'function GetNbFichesStations(): integer;'); sender.AddMethod(self , @TCdrPascalScript.ExportFichesToPDF , 'procedure ExportFichesToPDF(const QFilename: string; const QCompressed: boolean);'); sender.AddMethod(self , @TCdrPascalScript.EndListeFichesStations , 'procedure EndListeFichesStations();'); // maillages sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_LoadMaillageForIdx , 'function LST_Maillages_LoadMaillageForIdx(const QFilename: string; const Idx: integer): boolean;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GetNbVertexOfMaillage, 'function LST_Maillages_GetNbVertexOfMaillage(const Idx: integer): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GetNbTrianglesOfMaillage, 'function LST_Maillages_GetNbTrianglesOfMaillage(const Idx: integer): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_UnloadMaillage, 'procedure LST_Maillages_UnloadMaillage(const Idx: integer);'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_AddProfil , 'procedure MNT_AddProfil(const ProfilName: string; const X1, Y1, X2, Y2: double; const QCouleur: integer; const QOpacity: byte);'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_RemoveProfil , 'procedure LST_Maillages_RemoveProfil(const Idx: integer);'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GetNbProfils , 'function LST_Maillages_GetNbProfils(): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_ClearProfils , 'procedure LST_Maillages_ClearProfils();'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_ExtractBounds , 'function LST_Maillages_ExtractBounds(out QX1, QY1, QZ1, QX2, QY2, QZ2: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_ExtractAltitudeFromXY , 'function LST_Maillages_ExtractAltitudeFromXY(const QX, QY: double; out QZ: double): boolean'); EWE := 'function LST_Maillages_GenerateSetOfProfilsFromRect(const QNameSet:string; ' + 'const X1, Y1, X2, Y2, X3, Y3: double; ' + 'const NbProfilsHorizontaux : integer; ' + 'const NbProfilsVerticaux : integer; ' + 'const ColorMinH, ColorMaxH : integer; ' + // TColor est un integer 'const ColorMinV, ColorMaxV : integer; ' + 'const Sens: byte): boolean;'; sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GenerateSetOfProfilsFromRect , EWE); EWE := 'function LST_Maillages_GenerateSetOfProfilsFromQuad(const QNameSet: string; ' + 'const X1, Y1, X2, Y2, X3, Y3, X4, Y4: double; ' + 'const NbProfilsHorizontaux : integer; ' + 'const NbProfilsVerticaux : integer; ' + 'const ColorMinH, ColorMaxH : integer; ' + 'const ColorMinV, ColorMaxV : integer; ' + 'const Sens: byte): boolean;'; sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GenerateSetOfProfilsFromQuad , EWE); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_CheckerAltimetrieEntrees , 'procedure LST_Maillages_CheckerAltimetrieEntrees(const DoAdjustAtMNT: boolean; const DeltaZMax: double);'); EWE := 'procedure GRAPHE_GenererHTML(const PathStart, PathEnd: string; ' + 'const Width, Height, MenuWidth: integer; ' + 'const QNameItineraire: string; ' + 'const QFilename: string; ' + 'const QEtendueAutourStation: double; ' + 'const QMapBackgroundColor, QMapCenterlineColor: integer);'; sender.AddMethod(self , @TCdrPascalScript.GRAPHE_GenererHTML , EWE); sender.AddMethod(self , @TCdrPascalScript.GRAPHE_ExtractNode , 'procedure GRAPHE_ExtractNode(const Idx: integer);'); sender.AddMethod(self , @TCdrPascalScript.GRAPHE_FindShortestPath , 'function GRAPHE_FindShortestPath(const PathStart, PathEnd, Pathname: string): integer;'); sender.AddMethod(self , @TCdrPascalScript.GRAPHE_ExtractPathNode , 'procedure GRAPHE_ExtractPathNode(const QIdx: integer; out QIDStation: string; out QX, QY, QZ: double);'); // LISTE DES MAILLAGES // ================================================ sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GetNbMaillages , 'function LST_Maillages_GetNbMaillages(): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GetNomMaillage , 'function LST_Maillages_GetNomMaillage(const Idx:integer): string;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_GetNbProfils , 'function LST_Maillages_GetNbProfils(): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_LoadMaillageForIdx , 'function LST_Maillages_LoadMaillageForIdx(const QFilename: string; const Idx: integer): boolean;'); sender.AddMethod(self , @TCdrPascalScript.LST_Maillages_LoadMaillageAndAdd , 'function LST_Maillages_LoadMaillageAndAdd(const QFilename: string): boolean;'); //sender.AddMethod(self , @TCdrPascalScript. , ''); //sender.AddMethod(self , @TCdrPascalScript. , ''); //sender.AddMethod(self , @TCdrPascalScript. , ''); //sender.AddMethod(self , @TCdrPascalScript. , ''); //sender.AddMethod(self , @TCdrPascalScript. , ''); // // spécifique DIRA: PRAbscisse EWE := 'procedure DIRA_TGISLineString_ExtractFromString(const LS: string; ' + 'const Abscisse: double; out Length: double; ' + 'out AtAbscisseX, AtAbscisseY: double; ' + 'out MiddleAbscisseX, MiddleAbscisseY: double);'; sender.AddMethod(self , @TCdrPascalScript.DIRA_TGISLineString_ExtractFromString , EWE); // spécifique SQLITE // spécifique BRIC4 EWE := 'function BRIC4_ExtractFromDatagram(const D: string; ' + 'out Horodatage: string; ' + 'out Long, Azimut, Pente: single): boolean;'; {$IFDEF GHTOPO_SIMPLIFIE} sender.AddMethod(self , @TCdrPascalScript.BRIC4_ExtractFromDatagram, EWE); EWE := 'function BRIC4_MakeStrDatagramFromMesureLAPHorodatee(const Horodate: string; ' + 'const Long, Azimut, Pente: single): string;'; sender.AddMethod(self , @TCdrPascalScript.BRIC4_MakeStrDatagramFromMesureLAPHorodatee, EWE); {$endif GHTOPO_SIMPLIFIE} {$endif TOOLBOX_EMBEDDED_IN_GHTOPO} // QRCode sender.AddMethod(self , @TCdrPascalScript.QRCode_Generate , 'procedure QRCode_Generate(const ImgWidth: integer; const QFilenamePNG: string; const QTextToEncode: string);'); // display graphisme sender.AddMethod(self , @TCdrPascalScript.DRAW2D_BeginDrawing , 'function DRAW2D_BeginDrawing(const w, h: integer; const x1, y1, x2, y2: double; const Title: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_EndAndDisplayDrawing , 'procedure DRAW2D_EndAndDisplayDrawing();'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_SetBackgroundColor , 'procedure DRAW2D_SetBackgroundColor(const R, G, B, A: byte);'); EWE := 'function DRAW2D_AddStyleSheet(const QStylename: string; ' + 'const QPenColorR, QPenColorG, QPenColorB, QPenOpacity: byte; ' + 'const QPenWidtdhInPX: byte; const QPenWidthInMM: double; ' + 'const QBshColorR, QBshColorG, QBshColorB, QBshOpacity: byte; const QBshStyle: byte;' + 'const QFntName: string; const QFntColorR, QFntColorG, QFntColorB, QFntOpacity: byte;' + 'const QFntSizeInPX: byte; const QFntSizeInMM: double; '+ 'const QFntStyle: string): integer;'; sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddStyleSheet , EWE); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_SetStyleSheet , 'procedure DRAW2D_SetStyleSheet(const Idx:integer);'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddLayer , 'procedure DRAW2D_AddLayer(const QLayerName: string; const QAcadIdxColor: integer; const QR, QG, QB, QA: byte);'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_BeginPolyline , 'function DRAW2D_BeginPolyline(const QIdxLayer: integer; const QName: string; const Closed: boolean): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddVertex , 'procedure DRAW2D_AddVertex(const QX, QY: double);'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_EndPolyline , 'procedure DRAW2D_EndPolyline();'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddTexte , 'function DRAW2D_AddTexte(const QIdxLayer: integer; const QName: string; const QX, QY, AngleOrientation: double; const QAlignment: byte; const Texte: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddEllipse , 'function DRAW2D_AddEllipse(const QIdxLayer: integer; const QName: string; const QX, QY, QR1, QR2: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddRectangle , 'function DRAW2D_AddRectangle(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddLine , 'function DRAW2D_AddLine(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddTriangle , 'function DRAW2D_AddTriangle(const QIdxLayer: integer; const QName: string; const X1, Y1, X2, Y2, X3, Y3: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddMarker , 'function DRAW2D_AddMarker(const QIdxLayer: integer; const QName: string; const QX, QY: double; const QSize, QAlignment: byte; const QCaption: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddImage , 'function DRAW2D_AddImage(const QIdxLayer: integer; const QName: string; const QX1, QY1, QX2, QY2: double; const QFilename: string; const QCaption: string): boolean;'); // vertex et objets indexés sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddIndexedVertex , 'procedure DRAW2D_AddIndexedVertex(const QID: string; const QX, QY, QZ: double);'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_BeginListeIndexedVertex , 'procedure DRAW2D_BeginListeIndexedVertex();'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_FindIndexedVertexByID , 'function DRAW2D_FindIndexedVertexByID(const QID: string; out QInternalIdx: integer; out QIdentificateur: string; out QX, QY, QZ: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_getIndexedVertex , 'function DRAW2D_getIndexedVertex(const Idx: integer; out QID: string; out QX, QY, QZ: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_getNbIndexedVertex , 'function DRAW2D_getNbIndexedVertex(): integer;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_EndListeIndexedVertex , 'procedure DRAW2D_EndListeIndexedVertex();'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_BeginIndexedPolyline , 'function DRAW2D_BeginIndexedPolyline(const QIdxLayer: integer; const QName: string; const Closed: boolean): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddIndexOfVertex , 'procedure DRAW2D_AddIndexOfVertex(const Idx: string);'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_EndIndexedPolyline , 'procedure DRAW2D_EndIndexedPolyline();'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddIndexedTexte , 'function DRAW2D_AddIndexedTexte(const QIdxLayer: integer; const QName: string; const Cle: string; const QOffsetX, QOffsetY, AngleOrientation: double; const QAlignment: byte; const Texte: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.DRAW2D_AddIndexedMarker , 'function DRAW2D_AddIndexedMarker(const QIdxLayer: integer; const QName: string; const Cle: string; const QOffsetX, QOffsetY: double; const QSize, QAlignment: byte; const QCaption: string): boolean;'); // transferts FTP sender.AddMethod(self , @TCdrPascalScript.FTP_BeginConnexion , 'function FTP_BeginConnexion(const QHost: string; const QPort: integer; const QUser, QPassword: string; out QReturnCode: integer; out QReturnMsg: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.FTP_EndConnexion , 'procedure FTP_EndConnexion();'); sender.AddMethod(self , @TCdrPascalScript.FTP_GetFileName , 'function FTP_GetFileName(const Idx: integer): String;'); sender.AddMethod(self , @TCdrPascalScript.FTP_GetNbFilesOfLast , 'function FTP_GetNbFilesOfLast(): integer;'); sender.AddMethod(self , @TCdrPascalScript.FTP_ListFilenamesOf , 'function FTP_ListFilenamesOf(const Path: string): integer;'); sender.AddMethod(self , @TCdrPascalScript.FTP_SendFile , 'function FTP_SendFile(const QFilename: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.FTP_SetRemoteDirectory , 'procedure FTP_SetRemoteDirectory(const D: string);'); //sender.AddMethod(self , @TCdrPascalScript.FTP_, ''); //sender.AddMethod(self , @TCdrPascalScript.FTP_, ''); //sender.AddMethod(self , @TCdrPascalScript.FTP_, ''); sender.AddMethod(self , @TCdrPascalScript.DateTimePascalToSQL , 'function DateTimePascalToSQL(const D: double): string;'); sender.AddMethod(self , @TCdrPascalScript.DateTimeSqlToPascal , 'function DateTimeSqlToPascal(const D: string): double;'); // fonctions EXIF sender.AddMethod(self , @TCdrPascalScript.EXIF_ExtractPositionAndHorodatage , 'function EXIF_ExtractPositionAndHorodatage(const MyPhoto: string; out Lat, Lon, Alt: double; out Horodatage: double; out MsgErr: string): boolean;'); // parcours de dossiers sender.AddMethod(self , @TCdrPascalScript.FILE_FindFirst , 'function FILE_FindFirst(const QPath: string; out QFileFound: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.FILE_FindNext , 'function FILE_FindNext(out QFileFound: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.FILE_FindClose , 'procedure FILE_FindClose();'); // liste interne de résultats (TStringList) sender.AddMethod(self , @TCdrPascalScript.LST_RESULTS_Clear , 'procedure LST_RESULTS_Clear();'); sender.AddMethod(self , @TCdrPascalScript.LST_RESULTS_Add , 'procedure LST_RESULTS_Add(const S: string);'); sender.AddMethod(self , @TCdrPascalScript.LST_RESULTS_GetItem , 'function LST_RESULTS_GetItem(const Idx: integer): string;'); sender.AddMethod(self , @TCdrPascalScript.LST_RESULTS_GetNb , 'function LST_RESULTS_GetNb(): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_RESULTS_LoadFromFile , 'function LST_RESULTS_LoadFromFile(const QFilename: string): integer;'); sender.AddMethod(self , @TCdrPascalScript.LST_RESULTS_SaveToFile , 'procedure LST_RESULTS_SaveToFile(const QFilename: string);'); // carte OSM sender.AddMethod(self , @TCdrPascalScript.OSM_InitializeMap , 'function OSM_InitializeMap(const QFilename, QDocTitle: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.OSM_WriteHeader , 'procedure OSM_WriteHeader();'); sender.AddMethod(self , @TCdrPascalScript.OSM_AddPlacemark , 'procedure OSM_AddPlacemark(const QIdxLayer: integer; const QLat, QLon, QAltitude: double; const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string);'); sender.AddMethod(self , @TCdrPascalScript.OSM_AddLayer , 'procedure OSM_AddLayer(const QLayerIsAMap, QLayerDisplayed: boolean; const QLayerName: string; const QLayerTitle: string; const QLayerAttribution: string; const QURL: String; const QLayerMarkerStyle: integer; const QLayerMarkerSize: double; const QRed, QGreen, QBlue, QOpacity: integer);'); sender.AddMethod(self , @TCdrPascalScript.OSM_IdxLayerOf , 'function OSM_IdxLayerOf(const QLayerName: string): integer;'); sender.AddMethod(self , @TCdrPascalScript.OSM_GetNbLayers , 'function OSM_GetNbLayers(): integer;'); sender.AddMethod(self , @TCdrPascalScript.OSM_FinalizeMap , 'procedure OSM_FinalizeMap()'); // carte KML sender.AddMethod(self , @TCdrPascalScript.KML_InitializeMap , 'function KML_InitializeMap(const QFilename, QDocTitle: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.KML_WriteHeader , 'procedure KML_WriteHeader();'); EWE := 'procedure KML_AddPlacemark(const QNativeCoordX, QNativeCoordY: double; ' + 'const QLat, QLon, QAltitude: double; ' + 'const QEtiquette, QDesignation, QDescription, QObservations, QPhoto: string);'; sender.AddMethod(self , @TCdrPascalScript.KML_AddPlacemark , EWE); sender.AddMethod(self , @TCdrPascalScript.KML_BeginFolder , 'procedure KML_BeginFolder(const S: string);'); sender.AddMethod(self , @TCdrPascalScript.KML_EndFolder , 'procedure KML_EndFolder(const S: string);'); sender.AddMethod(self , @TCdrPascalScript.KML_FinalizeMap , 'procedure KML_FinalizeMap()'); // dialogues sender.AddMethod(self , @TCdrPascalScript.DLG_DoDialogListBox , 'function DialogListBox(const QTitle: string; out QSelectedIndex: integer; out QSelectedItem: string): boolean;'); // liste d'arguments (TGHStringArray) sender.AddMethod(self , @TCdrPascalScript.ARGV_Clear , 'procedure ARGV_Clear();'); sender.AddMethod(self , @TCdrPascalScript.ARGV_GetNthArgAsString , 'function ARGV_GetNthArgAsString(const idx: integer): string;'); sender.AddMethod(self , @TCdrPascalScript.ARGV_GetNthArgAsInteger , 'function ARGV_GetNthArgAsInteger(const idx: integer; const Default: integer): integer;'); sender.AddMethod(self , @TCdrPascalScript.ARGV_GetNthArgAsFloat , 'function ARGV_GetNthArgAsFloat(const idx: integer; const Default: double): double;'); sender.AddMethod(self , @TCdrPascalScript.ARGV_LineSplit , 'function ARGV_LineSplit(const S: string; const Sep: char): boolean;'); sender.AddMethod(self , @TCdrPascalScript.ARGV_GetNbArgs , 'function ARGV_GetNbArgs(): integer;'); // convertisseur de coordonnées sender.AddMethod(self , @TCdrPascalScript.ConversionCoordonneesEPSG , 'function ConversionCoordonneesEPSG(const Src, Tgt: integer; const PointInX, PointInY: double; out PointOutX, PointOutY: double): boolean;'); //sender.AddFunction(@ConversionCoordonneesIsoleesEPSG, 'function ConversionCoordonneesEPSG(const Src, Tgt: integer; const PointInX, PointInY: double; out PointOutX, PointOutY: double): boolean;'); // interrogation de BDD sender.AddMethod(self , @TCdrPascalScript.SQL_Connect , 'function SQL_Connect(const QHostName, QDatabaseName, QUsername, QPassword: string; const QPort: integer): boolean;'); sender.AddMethod(self , @TCdrPascalScript.SQL_Close , 'procedure SQL_Close();'); sender.AddMethod(self , @TCdrPascalScript.SQL_ClearResults , 'procedure SQL_ClearResults();'); sender.AddMethod(self , @TCdrPascalScript.SQL_ExecQuery , 'function SQL_ExecQuery(const QRequest: string): boolean; '); sender.AddMethod(self , @TCdrPascalScript.SQL_Result_GetNbCols , 'function SQL_Result_GetNbCols(): integer;'); sender.AddMethod(self , @TCdrPascalScript.SQL_Result_GetNbRows , 'function SQL_Result_GetNbRows(): integer;'); sender.AddMethod(self , @TCdrPascalScript.SQL_Result_GetValue , 'function SQL_Result_GetValue(const ARow, ACol: integer): string;'); // extraction d'une station de la BDD entités sender.AddMethod(self , @TCdrPascalScript.ExtractCoordsOfStation , 'function ExtractCoordsOfStation(const QSer, QSt: Integer; out QX, QY, QZ: double): boolean;'); // console d'entrée sender.AddMethod(self , @TCdrPascalScript.ConsoleEOF , 'function ConsoleEOF(): boolean;'); sender.AddMethod(self , @TCdrPascalScript.ClearInputConsole , 'procedure ClearInputConsole();'); sender.AddMethod(self , @TCdrPascalScript.ReadLineCin , 'procedure Readln(out QOutput: string);'); sender.AddMethod(self , @TCdrPascalScript.ReadLineCin , 'procedure cin(out QOutput: string);'); // Pour tests: Ecriture sur la console d'entrée sender.AddMethod(self , @TCdrPascalScript.WriteToConsoleIn , 'procedure WriteToConsoleIn(const S: string);'); sender.AddMethod(self , @TCdrPascalScript.ConsoleIsEmpty , 'function ConsoleIsEmpty(): boolean;'); // TArrayOfTPointLatLonAltAcc interne; sender.AddMethod(self , @TCdrPascalScript.ARR_XYZ_Redim , 'procedure ARR_XYZ_Redim(const Nb: integer);'); sender.AddMethod(self , @TCdrPascalScript.ARR_XYZ_GetNbElements , 'function ARR_XYZ_GetNbElements: integer; '); sender.AddMethod(self , @TCdrPascalScript.ARR_XYZ_AppendFrom , 'procedure ARR_XYZ_AppendFrom(const Lat, Lon, Alt, Acc, TagFloat: double; const QTag: string);'); sender.AddMethod(self , @TCdrPascalScript.ARR_XYZ_GetFrom , 'procedure ARR_XYZ_GetFrom(const Idx: integer; out Lat, Lon, Alt, Acc, TagFloat: double; out QTag: string);'); sender.AddMethod(self , @TCdrPascalScript.ARR_XYZ_GetBounds , 'procedure ARR_XYZ_GetBounds(out CX1, CY1, CZ1, CX2, CY2, CZ2: double);'); sender.AddMethod(self , @TCdrPascalScript.ARR_XYZ_AddBoundingBoxMargin , 'procedure ARR_XYZ_AddBoundingBoxMargin(const M: double);'); // BinHex sender.AddMethod(self , @TCdrPascalScript.BINHEX_Open , 'function BINHEX_Open(): boolean'); sender.AddMethod(self , @TCdrPascalScript.BINHEX_SendString , 'procedure BINHEX_SendString(const S: string);'); sender.AddMethod(self , @TCdrPascalScript.BINHEX_SaveToHex , 'function BINHEX_SaveToHex(const QFilename, Description: string): boolean;'); sender.AddMethod(self , @TCdrPascalScript.BINHEX_LoadFromHex , 'function BINHEX_LoadFromHex(const QFilename: string): integer;'); // SMTP sender.AddMethod(self , @TCdrPascalScript.SMTP_BeginTransaction , 'procedure SMTP_BeginTransaction(const ASubject: string);'); sender.AddMethod(self , @TCdrPascalScript.SMTP_AddLine , 'procedure SMTP_AddLine(const S: string);'); //sender.AddMethod(self , @TCdrPascalScript.SMTP_AddAttachment , 'procedure SMTP_AddAttachment(const S: string);'); sender.AddMethod(self , @TCdrPascalScript.SMTP_EndTransactionAndSend , 'procedure SMTP_EndTransactionAndSend(const ATo: string);'); // Carte OSM interactive sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_Create , 'function OSM_MAP_WIND_Create(const CodeEPSG: integer; const QX, QY: double): boolean;'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_AddLayer , 'procedure OSM_MAP_WIND_AddLayer(const QLayerName: string; const QOpacity: single); '); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_SetCurrentLayerByIdx , 'procedure OSM_MAP_WIND_SetCurrentLayerByIdx(const QIdx: integer);'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_SetCurrentLayerByName , 'procedure OSM_MAP_WIND_SetCurrentLayerByName(const QLayerName: string);'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_AddPoint , 'procedure OSM_MAP_WIND_AddPoint(const QX, QY, QZ: double; const QLabel: string);'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_BeginPolyLine , 'function OSM_MAP_WIND_BeginPolyLine(): boolean;'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_BeginPolygone , 'function OSM_MAP_WIND_BeginPolygone(): boolean;'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_AddVertex , 'procedure OSM_MAP_WIND_AddVertex(const QX, QY, QZ: double);'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_EndPolyLine , 'procedure OSM_MAP_WIND_EndPolyLine(const LR, LG, LB, LA: byte; const LineWidth: double);'); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_EndPolygone , 'procedure OSM_MAP_WIND_EndPolygone(const LR, LG, LB, LA: byte; const BR, BG, BB, BA: byte; const LineWidth: double);'); // sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_ , ''); // sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_ , ''); sender.AddMethod(self , @TCdrPascalScript.OSM_MAP_WIND_Display , 'procedure OSM_MAP_WIND_Display()'); // sender.AddMethod(self , @TCdrPascalScript., ''); (* sender.AddMethod(self , @TCdrPascalScript., ''); sender.AddMethod(self , @TCdrPascalScript., ''); sender.AddMethod(self , @TCdrPascalScript., ''); sender.AddMethod(self , @TCdrPascalScript., ''); sender.AddMethod(self , @TCdrPascalScript., ''); //*) //end; //*)