From feb6c624d635dd7ccf302e5b4daab1cc96728737 Mon Sep 17 00:00:00 2001 From: Patrick PREMARTIN Date: Sun, 10 Mar 2024 16:05:47 +0100 Subject: [PATCH] =?UTF-8?q?d=C3=A9placement=20des=20fichiers=20de=20la=20l?= =?UTF-8?q?ibrairie=20vers=20le=20sous-dossier=20"./src"=20pour=20homog?= =?UTF-8?q?=C3=A9n=C3=A9iser=20mes=20d=C3=A9p=C3=B4ts=20de=20code=20(#45)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Olf.FMX.Streams.pas | 72 + src/Olf.FMX.TextImageFrame.fmx | 6 + src/Olf.FMX.TextImageFrame.pas | 213 ++ src/Olf.RTL.DateAndTime.pas | 248 +++ src/Olf.RTL.Language.pas | 88 + src/Olf.RTL.Params.pas | 811 +++++++ src/Olf.RTL.Streams.pas | 106 + src/Olf.RTL.SystemAppearance.pas | 102 + src/Olf.VCL.Streams.pas | 72 + src/OlfSoftware_XML.dof | 89 + src/OlfSoftware_XML.dpk | 35 + src/XML_as_List.pas | 166 ++ src/f_operation_en_cours.dfm | Bin 0 -> 461 bytes src/f_operation_en_cours.pas | 91 + src/imports/AgentObjects_TLB.dcr | Bin 0 -> 308 bytes src/imports/AgentObjects_TLB.pas | 1227 +++++++++++ src/imports/MSXML_TLB.dcr | Bin 0 -> 16622 bytes src/imports/MSXML_TLB.pas | 3541 ++++++++++++++++++++++++++++++ src/microsoft_agent.dof | 87 + src/microsoft_agent.dpk | 34 + src/microsoft_xml.dof | 87 + src/microsoft_xml.dpk | 34 + src/uAjaxAnimation.pas | 64 + src/uChecksumVerif.pas | 108 + src/uDivers.pas | 25 + src/uGetDeviceName.pas | 77 + src/uKeyboardSpecialKeyTest.pas | 173 ++ src/uParam.pas | 58 + src/u_AnalysePageHTML.pas | 199 ++ src/u_GenerationUtilitaire.pas | 253 +++ src/u_android_media_scanner.pas | 57 + src/u_compteur_db.pas | 83 + src/u_compteur_reg.pas | 49 + src/u_download.pas | 77 + src/u_langue.pas | 25 + src/u_md5.pas | 27 + src/u_niveau_bdd.pas | 73 + src/u_scores.pas | 22 + src/u_urlOpen.pas | 45 + src/u_util.pas | 57 + src/u_version.pas | 63 + src/u_vibrate.pas | 79 + 42 files changed, 8723 insertions(+) create mode 100644 src/Olf.FMX.Streams.pas create mode 100644 src/Olf.FMX.TextImageFrame.fmx create mode 100644 src/Olf.FMX.TextImageFrame.pas create mode 100644 src/Olf.RTL.DateAndTime.pas create mode 100644 src/Olf.RTL.Language.pas create mode 100644 src/Olf.RTL.Params.pas create mode 100644 src/Olf.RTL.Streams.pas create mode 100644 src/Olf.RTL.SystemAppearance.pas create mode 100644 src/Olf.VCL.Streams.pas create mode 100644 src/OlfSoftware_XML.dof create mode 100644 src/OlfSoftware_XML.dpk create mode 100644 src/XML_as_List.pas create mode 100644 src/f_operation_en_cours.dfm create mode 100644 src/f_operation_en_cours.pas create mode 100644 src/imports/AgentObjects_TLB.dcr create mode 100644 src/imports/AgentObjects_TLB.pas create mode 100644 src/imports/MSXML_TLB.dcr create mode 100644 src/imports/MSXML_TLB.pas create mode 100644 src/microsoft_agent.dof create mode 100644 src/microsoft_agent.dpk create mode 100644 src/microsoft_xml.dof create mode 100644 src/microsoft_xml.dpk create mode 100644 src/uAjaxAnimation.pas create mode 100644 src/uChecksumVerif.pas create mode 100644 src/uDivers.pas create mode 100644 src/uGetDeviceName.pas create mode 100644 src/uKeyboardSpecialKeyTest.pas create mode 100644 src/uParam.pas create mode 100644 src/u_AnalysePageHTML.pas create mode 100644 src/u_GenerationUtilitaire.pas create mode 100644 src/u_android_media_scanner.pas create mode 100644 src/u_compteur_db.pas create mode 100644 src/u_compteur_reg.pas create mode 100644 src/u_download.pas create mode 100644 src/u_langue.pas create mode 100644 src/u_md5.pas create mode 100644 src/u_niveau_bdd.pas create mode 100644 src/u_scores.pas create mode 100644 src/u_urlOpen.pas create mode 100644 src/u_util.pas create mode 100644 src/u_version.pas create mode 100644 src/u_vibrate.pas diff --git a/src/Olf.FMX.Streams.pas b/src/Olf.FMX.Streams.pas new file mode 100644 index 0000000..d9cf31e --- /dev/null +++ b/src/Olf.FMX.Streams.pas @@ -0,0 +1,72 @@ +unit Olf.FMX.Streams; + +interface + +uses + FMX.Graphics, + System.SysUtils, + System.Classes; + +procedure SaveBitmapToStream(ABitmap: TBitmap; AToStream: TStream); +function LoadBitmapFromStream(AFromStream: TStream): TBitmap; + +implementation + +procedure SaveBitmapToStream(ABitmap: TBitmap; AToStream: TStream); +var + ms: TMemoryStream; + size: int64; +begin + if not assigned(AToStream) then + raise exception.create('Need an existing stream to save the bitmap !'); + + if not assigned(ABitmap) then + begin + size := 0; + AToStream.WriteData(size); + end + else + begin + ms := TMemoryStream.create; + try + ABitmap.SaveToStream(ms); + size := ms.size; + AToStream.WriteData(size); + if (size > 0) then + begin + ms.Position := 0; + AToStream.CopyFrom(ms, size); + end; + finally + ms.free; + end; + end; +end; + +function LoadBitmapFromStream(AFromStream: TStream): TBitmap; +var + ms: TMemoryStream; + size: int64; +begin + if not assigned(AFromStream) then + raise exception.create('Need an existing stream to load the bitmap !'); + + if (AFromStream.ReadData(size) <> sizeof(size)) then + result := nil + else if (size < 1) then + result := nil + else + begin + ms := TMemoryStream.create; + try + ms.CopyFrom(AFromStream, size); + ms.Position := 0; + result := TBitmap.create; + result.LoadFromStream(ms); + finally + ms.free; + end; + end; +end; + +end. \ No newline at end of file diff --git a/src/Olf.FMX.TextImageFrame.fmx b/src/Olf.FMX.TextImageFrame.fmx new file mode 100644 index 0000000..0282edb --- /dev/null +++ b/src/Olf.FMX.TextImageFrame.fmx @@ -0,0 +1,6 @@ +object OlfFMXTextImageFrame: TOlfFMXTextImageFrame + HitTest = False + Size.Width = 320.000000000000000000 + Size.Height = 240.000000000000000000 + Size.PlatformDefault = False +end diff --git a/src/Olf.FMX.TextImageFrame.pas b/src/Olf.FMX.TextImageFrame.pas new file mode 100644 index 0000000..7b20061 --- /dev/null +++ b/src/Olf.FMX.TextImageFrame.pas @@ -0,0 +1,213 @@ +unit Olf.FMX.TextImageFrame; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, + System.Variants, + FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls, + System.ImageList, FMX.ImgList; + +type + TOlfFMXTextImageFrame = class; + + TOlfFMXTIFOnGetImageIndexOfUnknowChar = function + (Sender: TOlfFMXTextImageFrame; AChar: char): integer of object; + + TOlfFMXTextImageFrame = class(TFrame) + private + FText: string; + FFont: TCustomImageList; + FOnGetImageIndexOfUnknowChar: TOlfFMXTIFOnGetImageIndexOfUnknowChar; + FLetterSpacing: single; + FSpaceWidth, FRealSpaceWidth: single; + procedure SetFont(const Value: TCustomImageList); + procedure SetText(const Value: string); + procedure SetOnGetImageIndexOfUnknowChar(const Value + : TOlfFMXTIFOnGetImageIndexOfUnknowChar); + procedure SetLetterSpacing(const Value: single); + procedure SetSpaceWidth(const Value: single); + protected + function AjoutImageEtRetourneLargeur(AImages: TCustomImageList; + AImageIndex: TImageIndex; AX: single): single; + procedure RefreshTexte; + public + property Font: TCustomImageList read FFont write SetFont; + property Text: string read FText write SetText; + property SpaceWidth: single read FSpaceWidth write SetSpaceWidth; + property LetterSpacing: single read FLetterSpacing write SetLetterSpacing; + property OnGetImageIndexOfUnknowChar: TOlfFMXTIFOnGetImageIndexOfUnknowChar + read FOnGetImageIndexOfUnknowChar write SetOnGetImageIndexOfUnknowChar; + constructor Create(AOwner: TComponent); override; + function RetourneLargeur(AImages: TCustomImageList; + AImageIndex: TImageIndex): single; + function getImageIndexOfChar(AChar: string): integer; + end; + +implementation + +{$R *.fmx} + +const + CPosChiffres = 0; + CPosMajuscules = CPosChiffres + 10; + CPosMinuscules = CPosMajuscules; + // Pas de minuscules dans les fontes prises sur ce jeu + CPosPonctuation = CPosMajuscules + 26; + // TODO : à modifier si nécessaire selon les fontes + + { TcadAffichageTexteGraphique } + +function TOlfFMXTextImageFrame.AjoutImageEtRetourneLargeur + (AImages: TCustomImageList; AImageIndex: TImageIndex; AX: single): single; +var + g: tglyph; + wi, hi: single; +begin + if (not assigned(AImages)) or (AImageIndex < 0) or + (AImageIndex >= AImages.Count) then + result := 0 + else + begin + g := tglyph.Create(self); + g.Parent := self; + wi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].Width; + hi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].height; + g.height := height; + g.Width := g.height * wi / hi; + g.Images := AImages; + g.ImageIndex := AImageIndex; + g.Position.x := AX; + g.Position.y := 0; + result := g.Width; + end; +end; + +constructor TOlfFMXTextImageFrame.Create(AOwner: TComponent); +begin + inherited; + name := ''; + FFont := nil; + FText := ''; + FLetterSpacing := 0; + FSpaceWidth := 0; + FRealSpaceWidth := 0; + FOnGetImageIndexOfUnknowChar := nil; +end; + +function TOlfFMXTextImageFrame.getImageIndexOfChar(AChar: string): integer; +begin + result := 0; + while (result < FFont.Count) and + (FFont.Destination[result].Layers[0].Name <> AChar) do + inc(result); + if (result >= FFont.Count) then + result := -1; +end; + +procedure TOlfFMXTextImageFrame.RefreshTexte; +var + i: integer; + x: single; + idx: integer; +begin + for i := childrencount - 1 downto 0 do + if (children[i] is tglyph) then + children[i].Free; + + x := 0; + if assigned(FFont) and (FText.Length > 0) then + for i := 0 to FText.Length - 1 do + begin + idx := getImageIndexOfChar(FText.Chars[i]); + if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then + idx := FOnGetImageIndexOfUnknowChar(self, FText.Chars[i]); + if (idx >= 0) then + x := x + AjoutImageEtRetourneLargeur(FFont, idx, x) + FLetterSpacing + else if (FText.Chars[i] = ' ') then + begin + if (FRealSpaceWidth < 1) then + begin + idx := getImageIndexOfChar('.'); + if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then + idx := FOnGetImageIndexOfUnknowChar(self, '.'); + if (idx >= 0) then + FRealSpaceWidth := RetourneLargeur(FFont, idx); + + idx := getImageIndexOfChar('i'); + if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then + idx := FOnGetImageIndexOfUnknowChar(self, 'i'); + if (idx >= 0) then + FRealSpaceWidth := RetourneLargeur(FFont, idx); + + idx := getImageIndexOfChar('I'); + if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then + idx := FOnGetImageIndexOfUnknowChar(self, 'I'); + if (idx >= 0) then + FRealSpaceWidth := RetourneLargeur(FFont, idx); + + idx := getImageIndexOfChar('1'); + if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then + idx := FOnGetImageIndexOfUnknowChar(self, '1'); + if (idx >= 0) then + FRealSpaceWidth := RetourneLargeur(FFont, idx); + end; + x := x + FRealSpaceWidth; + end; + end; + + Width := x; +end; + +function TOlfFMXTextImageFrame.RetourneLargeur(AImages: TCustomImageList; + AImageIndex: TImageIndex): single; +var + wi, hi: single; +begin + if (not assigned(AImages)) or (AImageIndex < 0) or + (AImageIndex >= AImages.Count) then + result := 0 + else + begin + wi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].Width; + hi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].height; + result := height * wi / hi; + end; +end; + +procedure TOlfFMXTextImageFrame.SetFont(const Value: TCustomImageList); +begin + FFont := Value; + FRealSpaceWidth := FSpaceWidth; + if (FText.Length > 0) then + RefreshTexte; +end; + +procedure TOlfFMXTextImageFrame.SetLetterSpacing(const Value: single); +begin + FLetterSpacing := Value; +end; + +procedure TOlfFMXTextImageFrame.SetOnGetImageIndexOfUnknowChar + (const Value: TOlfFMXTIFOnGetImageIndexOfUnknowChar); +begin + FOnGetImageIndexOfUnknowChar := Value; +end; + +procedure TOlfFMXTextImageFrame.SetSpaceWidth(const Value: single); +begin + FSpaceWidth := Value; + FRealSpaceWidth := FSpaceWidth; +end; + +procedure TOlfFMXTextImageFrame.SetText(const Value: string); +begin + FText := Value; + if not assigned(FFont) then + exit; + RefreshTexte; +end; + +// TODO : gérer changement de taille des chiffres en cas de resize de la zone + +end. diff --git a/src/Olf.RTL.DateAndTime.pas b/src/Olf.RTL.DateAndTime.pas new file mode 100644 index 0000000..bfa5ba4 --- /dev/null +++ b/src/Olf.RTL.DateAndTime.pas @@ -0,0 +1,248 @@ +unit Olf.RTL.DateAndTime; + +interface + +/// +/// Ressort la date du jour en AAAAMMJJ +/// +function DateToString8: string; overload; + +/// +/// Ressort la date passée en AAAAMMJJ +/// +function DateToString8(Const ADate: TDateTime): string; overload; + +/// +/// Get the TDate value of a YYYYMMDD string +/// +function Date8ToDate(Const Date8: string): tdate; + +/// +/// Transforme une date AAAAMMJJ dans son format d'affichage JJ/MM/AAAA +/// +function Date8ToString(Const Date8AAfficher: string): string; + +/// +/// Transforme une date AAAAMMJJ dans son format d'affichage AAAA-MM-JJ +/// +function Date8ToStringISO(Const Date8AAfficher: string): string; + +/// +/// Transforme une date AAAAMMJJ dans son format d'affichage RFC822 +/// +function Date8ToStringRFC822(Const Date8AAfficher: string): string; + +/// +/// Ressort l'heure en cours en HHMMSS +/// +function TimeToString6: string; overload; + +/// +/// Ressort l'heure passée en HHMMSS +/// +function TimeToString6(Const ATime: TDateTime): string; overload; + +/// +/// Transforme une heure HHMMSS dans son format d'affichage HH:MM:SS +/// +function Time6ToString(Const Time6AAfficher: string): string; + +/// +/// Transforme la date et heure du moment en AAAAMMJJHHMMSS +/// Ce format est utilisé dans le stockage d'infos de création et de modification dans la base de données et permettre des tris chronologiques sur l'ordre alphabétique. +/// +function DateTimeToString14: string; overload; + +/// +/// Transforme la date et heure passée en AAAAMMJJHHMMSS +/// Ce format est utilisé dans le stockage d'infos de création et de modification dans la base de données et permettre des tris chronologiques sur l'ordre alphabétique. +/// +function DateTimeToString14(Const ADateTime: TDateTime): string; overload; + +/// +/// Converti une valeur en secondes vers son équivalent en HMS +/// +function SecToHMS(Const Valeur_En_secondes: Integer): String; overload; +procedure SecToHMS(Const Valeur_En_secondes: Integer; + var HH, MM, SS: Integer); overload; + +/// +/// Converti une valeur HMS (xxH xxM xxS) en son équivalent en secondes +/// +function HMSToSec(Const Valeur_En_HMS: String): Integer; overload; +function HMSToSec(Const HH, MM, SS: Integer): Integer; overload; + +implementation + +uses + System.SysUtils, + System.StrUtils, + System.Character; + +function DateToString8: string; +begin + Result := DateToString8(Now); +end; + +function DateToString8(Const ADate: TDateTime): string; +begin + Result := FormatDateTime('yyyymmdd', ADate); +end; + +function Date8ToDate(Const Date8: string): tdate; +begin + Result := EncodeDate(Date8.Substring(0, 4).tointeger, + Date8.Substring(4, 2).tointeger, Date8.Substring(6, 2).tointeger); +end; + +function Date8ToString(Const Date8AAfficher: string): string; +var + MM, jj: string; +begin + // TODO : gérer les formats de date non européens de l'ouest + MM := Date8AAfficher.Substring(4, 2); + jj := Date8AAfficher.Substring(6, 2); + if MM = '00' then + Result := Date8AAfficher.Substring(0, 4) + else if jj = '00' then + Result := MM + FormatSettings.DateSeparator + Date8AAfficher.Substring(0, 4) + else + Result := jj + FormatSettings.DateSeparator + MM + + FormatSettings.DateSeparator + Date8AAfficher.Substring(0, 4); +end; + +function Date8ToStringISO(Const Date8AAfficher: string): string; +var + MM, jj: string; +begin + // TODO : gérer les formats de date non européens de l'ouest + MM := Date8AAfficher.Substring(4, 2); + jj := Date8AAfficher.Substring(6, 2); + if MM = '00' then + Result := Date8AAfficher.Substring(0, 4) + '-00-00' + else if jj = '00' then + Result := Date8AAfficher.Substring(0, 4) + '-' + MM + '-00' + else + Result := Date8AAfficher.Substring(0, 4) + '-' + MM + '-' + jj; +end; + +function Date8ToStringRFC822(Const Date8AAfficher: string): string; +var + x: Integer; +begin + if Date8AAfficher.IsEmpty then + raise Exception.Create + ('Date non renseignée. Impossible à convertir dans Date8ToStringRFC822.'); + x := Date8AAfficher.Substring(6, 2).tointeger; + if x < 1 then + x := 1; + Result := x.ToString + ' '; + case Date8AAfficher.Substring(4, 2).tointeger of + 0, 1: + Result := Result + 'Jan'; + 2: + Result := Result + 'Feb'; + 3: + Result := Result + 'Mar'; + 4: + Result := Result + 'Apr'; + 5: + Result := Result + 'May'; + 6: + Result := Result + 'Jun'; + 7: + Result := Result + 'Jul'; + 8: + Result := Result + 'Aug'; + 9: + Result := Result + 'Sep'; + 10: + Result := Result + 'Oct'; + 11: + Result := Result + 'Nov'; + 12: + Result := Result + 'Dec'; + end; + Result := Result + ' ' + Date8AAfficher.Substring(0, 4) + ' 00:00:00 GMT'; +end; + +function TimeToString6: string; +begin + Result := TimeToString6(Now); +end; + +function TimeToString6(Const ATime: TDateTime): string; +begin + Result := FormatDateTime('hhnnss', ATime); +end; + +function Time6ToString(Const Time6AAfficher: string): string; +begin + Result := Time6AAfficher.Substring(0, 2) + FormatSettings.TimeSeparator + + Time6AAfficher.Substring(2, 2) + FormatSettings.TimeSeparator + + Time6AAfficher.Substring(4, 2); +end; + +function DateTimeToString14: string; +begin + Result := DateTimeToString14(Now); +end; + +function DateTimeToString14(Const ADateTime: TDateTime): string; +begin + Result := DateToString8(ADateTime) + TimeToString6(ADateTime); +end; + +function SecToHMS(Const Valeur_En_secondes: Integer): String; +var + h, m, s: Integer; +begin + SecToHMS(Valeur_En_secondes, h, m, s); + Result := ''; + if (h > 0) then + Result := Result + h.ToString + 'H '; + if (m > 0) then + Result := Result + m.ToString + 'M '; + if (s > 0) or (Valeur_En_secondes = 0) then + Result := Result + s.ToString + 'S '; +end; + +procedure SecToHMS(Const Valeur_En_secondes: Integer; var HH, MM, SS: Integer); +begin + SS := Valeur_En_secondes; + HH := SS div SecsPerHour; + SS := SS - HH * SecsPerHour; + MM := SS div SecsPerMin; + SS := SS - MM * SecsPerMin; +end; + +function HMSToSec(Const Valeur_En_HMS: String): Integer; +var + ch: string; + i: Integer; +begin + Result := 0; + ch := Valeur_En_HMS.Trim.Replace(' ', '').ToUpper; + i := ch.IndexOf('H'); + if (i > 0) then + begin + Result := Result + ch.Substring(0, i).tointeger * SecsPerHour; + ch := ch.Substring(i + 1); + end; + i := ch.IndexOf('M'); + if (i > 0) then + begin + Result := Result + ch.Substring(0, i).tointeger * SecsPerMin; + ch := ch.Substring(i + 1); + end; + i := ch.IndexOf('S'); + if (i > 0) then + Result := Result + ch.Substring(0, i).tointeger; +end; + +function HMSToSec(Const HH, MM, SS: Integer): Integer; +begin + Result := HH * SecsPerHour + MM * SecsPerMin + SS; +end; + +end. diff --git a/src/Olf.RTL.Language.pas b/src/Olf.RTL.Language.pas new file mode 100644 index 0000000..6adcfa1 --- /dev/null +++ b/src/Olf.RTL.Language.pas @@ -0,0 +1,88 @@ +unit Olf.RTL.Language; + +// (c) Patrick Prémartin 02/2023 +// +// This file is distributed under AGPL license. +// +// Get the latest version at +// https://github.com/DeveloppeurPascal/librairies + +interface + +/// +/// Get current language code (like "fr-fr" or "en-gb") +/// The result is lower cased. +/// +function GetCurrentLanguageCode: String; + +/// +/// Get current language ISO code (like "fr" or "en") +/// This function returns first 2 letters of GetcurrentLanguageCode. +/// The result is lower cased. +/// +function GetCurrentLanguageISOCode: String; + +implementation + +// Created from this forum posts : +// https://forums.embarcadero.com/thread.jspa?threadID=108333 +// http://www.synaptica.info/en/2015/12/21/delphi-10seattle-get-current-device-language/ +// http://codeverge.com/embarcadero.delphi.firemonkey/detect-current-language-on-andr/2001235#sthash.zjLIi2KY.dpuf + +{$IF Defined(MSWINDOWS)} + +uses Winapi.Windows, System.SysUtils; +{$ELSEIF Defined(IOS)} + +uses MacAPI.ObjectiveC, iOSapi.Foundation, System.SysUtils; +{$ELSEIF Defined(MACOS)} + +uses MacAPI.ObjectiveC, MacAPI.Foundation, System.SysUtils; +{$ELSE} + +// Android + Linux +uses FMX.Platform, System.SysUtils; +{$ENDIF} + +function GetCurrentLanguageCode: String; +{$IF Defined(MSWINDOWS)} +var + buffer: PWideChar; + UserLCID: LCID; + BufLen: Integer; +begin + // defaults + UserLCID := GetUserDefaultLCID; + BufLen := GetLocaleInfo(UserLCID, LOCALE_SISO639LANGNAME, nil, 0); + buffer := StrAlloc(BufLen); + if GetLocaleInfo(UserLCID, LOCALE_SISO639LANGNAME, buffer, BufLen) <> 0 then + Result := lowercase(buffer) + else + Result := 'en'; + StrDispose(buffer); +end; +{$ELSEIF Defined(MACOS) or Defined(IOS)} + +var + Languages: NSArray; +begin + Languages := TNSLocale.OCClass.preferredLanguages; + Result := lowercase(TNSString.Wrap(Languages.objectAtIndex(0)).UTF8String); +end; +{$ELSE} + +var + LocServ: IFMXLocaleService; +begin + if TPlatformServices.Current.SupportsPlatformService(IFMXLocaleService, + IInterface(LocServ)) then + Result := LocServ.GetCurrentLangID; +end; +{$ENDIF} + +function GetCurrentLanguageISOCode: String; +begin + Result := GetCurrentLanguageCode.Substring(0, 2); +end; + +end. diff --git a/src/Olf.RTL.Params.pas b/src/Olf.RTL.Params.pas new file mode 100644 index 0000000..3d7504b --- /dev/null +++ b/src/Olf.RTL.Params.pas @@ -0,0 +1,811 @@ +unit Olf.RTL.Params; + +{ + Gestion automatisée d'un fichier de stockage sous forme de dictionnaire de + données (clé / valeur) pour les logiciels développés sous Delphi. + + Logiciel open source distribué sous licence MIT. + Open source software distributed under the MIT license + + Copyright Patrick Prémartin / Olf Software + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. + + Find the original source code on + https://github.com/DeveloppeurPascal/librairies + + Find explanations on + https://developpeur-pascal.fr/plutot-ini-ou-json-pour-stocker-vos-parametres.html + + Liste des mises à jour : + => 11/05/2020, Patrick Prémartin : + * ajout de la notice de copyright et licence d'utilisation + * gestion de données de types Syngle et TDataTime + * correction d'une perte de mémoire au niveau du remplacement d'une valeur sur un paramètre existant + => 22/04/2022, Patrick PRémartin : + * ajout de la procédure setFolderName() pour permettre la modification du dossier de stockage du fichier de paramètres + => 19/05/2022, Patrick Prémartin : + * creation de Olf.RTL.Params à partir de uParam + * ajout de la fonction ToJSON permettant d'obtenir la représentation du fichier de stockage sous forme de chaîne JSON + * ajout de la fonction AsJSONObject pour obtenir la représentation sous forme de TJSONObject des paramètres + * ajout de la fonction getFilePath pour obtenir le nom du fichier de stockage avec son chemin d'accès (attention : ne le modifiez pas en direct si vous utilisez aussi la classe TParams dans votre projet) + * ajout de la procédure setFilePath() pour définir le chemin et le nom du fichier de stockage des paramètres + * ajout de valeurs par défaut pour la valeur par défaut dans les fonctions getValue() + * ajout des commentaires XMLDoc + * ajout de la classe TParamsFile pour rendre possible la manipulation de plusieurs fichiers de paramètres si on en a besoin + * ajout de MoveToFilePath() pour déplacer le fichier de paramètres actuel + * ajout de setValue et getValue pour des TJSONValue et ses descendants + => 31/12/2023, Patrick Prémartin : + * ajout d'une variante "cardinal" du getValue() et SetValue() +} +interface + +uses + System.JSON; + +type + TParamsFile = class(TObject) + private + FParamChanged: boolean; + FParamList: TJSONObject; + FFolderName: string; + FFileName: string; + protected + function getParamsFileName(ACreateFolder: boolean = False): string; + function getParamValue(key: string): TJSONValue; + procedure setParamValue(key: string; value: TJSONValue); + public + /// + /// Class constructor wich just initialize private fields. + /// + constructor Create; overload; + /// + /// Class constructor wich loads the parameter file specified as parameter. + /// + /// + /// Absolute file path to the parameter file (drive+folder+file name+extension) + /// + constructor Create(AFilePath: string); overload; + /// + /// Instance destructor + /// + destructor Destroy; override; + /// + /// Save current parameters to actual parameter file + /// + procedure Save; + /// + /// Load parameters from actual parameter file + /// + procedure Load; + /// + /// Cancel current changes and reload previous saved values + /// + procedure Cancel; + /// + /// Get the string value for key parameter with an empty string as default value + /// + function getValue(key: string; default: string = ''): string; overload; + /// + /// Get the boolean value for key parameter with False as default value + /// + function getValue(key: string; default: boolean = False): boolean; overload; + /// + /// Get the cardinal value for key parameter with zero as default value + /// + function getValue(key: string; default: cardinal = 0): cardinal; overload; + /// + /// Get the integer value for key parameter with zero as default value + /// + function getValue(key: string; default: integer = 0): integer; overload; + /// + /// Get the single value for key parameter with zero as default value + /// + function getValue(key: string; default: single = 0): single; overload; + /// + /// Get the TDateTime value for key parameter with December 30th 1899 at 12:00 as default value + /// + function getValue(key: string; default: TDateTime = 0): TDateTime; overload; + /// + /// Get the JSON value for key parameter with nil as default value + /// + function getValue(key: string; default: TJSONValue = nil) + : TJSONValue; overload; + /// + /// Set the value for key parameter as string + /// + procedure setValue(key, value: string); overload; + /// + /// Set the value for key parameter as boolean + /// + procedure setValue(key: string; value: boolean); overload; + /// + /// Set the value for key parameter as cardinal + /// + procedure setValue(key: string; value: cardinal); overload; + /// + /// Set the value for key parameter as integer + /// + procedure setValue(key: string; value: integer); overload; + /// + /// Set the value for key parameter as single + /// + procedure setValue(key: string; value: single); overload; + /// + /// Set the value for key parameter as TDateTime + /// + procedure setValue(key: string; value: TDateTime); overload; + /// + /// Set the value for key parameter as TJSONValue + /// + procedure setValue(key: string; value: TJSONValue); overload; + /// + /// Change the folder where is the parameter file. + /// + /// + /// Absolute folder path where you want to save the parameter file. + /// + /// + /// If set to True (by default), call the Load procedure after changing the folder. + /// + /// + /// To change the file name, use setFilePath() instead of setFolderName(). + /// + procedure setFolderName(AFolderName: string; AReload: boolean = true); + /// + /// Change the folder where is the parameter file. + /// + /// + /// Absolute file path (drive+folder+file name+extension) to the parameter file you want to use. + /// + /// + /// If set to True (by default), call Load procedure after changing the file path. + /// + /// + /// If you only want to change the path to the parameter file, use setFolderName procedure instead of this one. + /// + procedure setFilePath(AFilePath: string; AReload: boolean = true); + /// + /// Move actual parameter file to the new file. + /// + /// + /// Absolute file path (drive+folder+file name+extension) to the parameter file you want to use. + /// + /// + /// If set to True, save actual values to the parameter file. + /// If set to false, just move the parameter file to it's new folder/filename. + /// + /// + /// If set to True, create the folder of file parameter if it doesn't exists. + /// + procedure MoveToFilePath(ANewFilePath: string; ASave: boolean = true; + ACreateFolder: boolean = False); + /// + /// Return the absolute path to the parameter file (drive+folder+file name+extension) + /// + function getFilePath: string; + /// + /// Return the current parameters as a serialized JSON object. + /// + function ToJSON: string; + /// + /// Return the current parameters as a JSON object + /// + /// + /// If set to True (by default), the result is a clone of actual object. Free it when you have finished to work with it or you'll have memory leaks in your projects. + /// If set to False, the result is a reference to the internal JSON object. All changes are made to it. Don't destroy it or you'll have Access Violation exception. + /// + function AsJSONObject(AClone: boolean = true): TJSONObject; + end; + + TParams = class(TObject) + public + /// + /// Save current parameters to actual parameter file + /// + class procedure Save; + /// + /// Load parameters from actual parameter file + /// + class procedure Load; + /// + /// Get the string value for key parameter with an empty string as default value + /// + class function getValue(key: string; default: string = ''): string; + overload; + /// + /// Get the boolean value for key parameter with False as default value + /// + class function getValue(key: string; default: boolean = False) + : boolean; overload; + /// + /// Get the integer value for key parameter with zero as default value + /// + class function getValue(key: string; default: integer = 0) + : integer; overload; + /// + /// Get the cardinal value for key parameter with zero as default value + /// + class function getValue(key: string; default: cardinal = 0) + : integer; overload; + /// + /// Get the single value for key parameter with zero as default value + /// + class function getValue(key: string; default: single = 0): single; overload; + /// + /// Get the TDateTime value for key parameter with December 30th 1899 at 12:00 as default value + /// + class function getValue(key: string; default: TDateTime = 0) + : TDateTime; overload; + /// + /// Get the JSON value for key parameter with nil as default value + /// + class function getValue(key: string; default: TJSONValue = nil) + : TJSONValue; overload; + /// + /// Set the value for key parameter as string + /// + class procedure setValue(key, value: string); overload; + /// + /// Set the value for key parameter as boolean + /// + class procedure setValue(key: string; value: boolean); overload; + /// + /// Set the value for key parameter as integer + /// + class procedure setValue(key: string; value: integer); overload; + /// + /// Set the value for key parameter as cardinal + /// + class procedure setValue(key: string; value: cardinal); overload; + /// + /// Set the value for key parameter as single + /// + class procedure setValue(key: string; value: single); overload; + /// + /// Set the value for key parameter as TDateTime + /// + class procedure setValue(key: string; value: TDateTime); overload; + /// + /// Set the value for key parameter as TJSONValue + /// + class procedure setValue(key: string; value: TJSONValue); overload; + /// + /// Change the folder where is the parameter file. + /// + /// + /// Absolute folder path where you want to save the parameter file. + /// + /// + /// If set to True (by default), call the Load procedure after changing the folder. + /// + /// + /// To change the file name, use setFilePath() instead of setFolderName(). + /// + class procedure setFolderName(AFolderName: string; AReload: boolean = true); + /// + /// Change the folder where is the parameter file. + /// + /// + /// Absolute file path (drive+folder+file name+extension) to the parameter file you want to use. + /// + /// + /// If set to True (by default), call Load procedure after changing the file path. + /// + /// + /// If you only want to change the path to the parameter file, use setFolderName procedure instead of this one. + /// + class procedure setFilePath(AFilePath: string; AReload: boolean = true); + /// + /// Move actual parameter file to the new file. + /// + /// + /// Absolute file path (drive+folder+file name+extension) to the parameter file you want to use. + /// + /// + /// If set to True, save actual values to the parameter file. + /// If set to false, just move the parameter file to it's new folder/filename. + /// + /// + /// If set to True, create the folder of file parameter if it doesn't exists. + /// + class procedure MoveToFilePath(ANewFilePath: string; ASave: boolean = true; + ACreateFolder: boolean = False); + /// + /// Return the absolute path to the parameter file (drive+folder+file name+extension) + /// + class function getFilePath: string; + /// + /// Return the current parameters as a serialized JSON object. + /// + class function ToJSON: string; + /// + /// Return the current parameters as a JSON object + /// + class function AsJSONObject: TJSONObject; + end; + +implementation + +uses + System.Generics.collections, System.IOUtils, System.SysUtils, System.Classes; + +{ TParamsFile } + +function TParamsFile.getParamsFileName(ACreateFolder: boolean = False): string; +var + folder: string; + filename: string; + app_name: string; +begin + app_name := TPath.GetFileNameWithoutExtension(paramstr(0)); + + // get filename + if FFileName.IsEmpty then + begin +{$IF Defined(DEBUG)} + filename := app_name + '-debug.par'; +{$ELSE if Defined(RELEASE)} + filename := app_name + '.par'; +{$ELSE} +{$MESSAGE FATAL 'setup problem'} +{$ENDIF} end + else + filename := FFileName; + + // get folder name + if FFolderName.IsEmpty then + folder := TPath.Combine(TPath.GetDocumentsPath, app_name) + else + folder := FFolderName; + if ACreateFolder and (not tdirectory.Exists(folder)) then + tdirectory.CreateDirectory(folder); + + // get file path + result := TPath.Combine(folder, filename); +end; + +function TParamsFile.getParamValue(key: string): TJSONValue; +begin + result := nil; + if assigned(FParamList) then + if (FParamList.Count > 0) then + result := FParamList.getValue(key); +end; + +procedure TParamsFile.setParamValue(key: string; value: TJSONValue); +begin + if not assigned(FParamList) then + FParamList := TJSONObject.Create + else if (FParamList.Count > 0) and (nil <> FParamList.getValue(key)) then + FParamList.RemovePair(key).Free; + FParamList.AddPair(key, value); + FParamChanged := true; +end; + +procedure TParamsFile.setValue(key: string; value: cardinal); +var + jsonvalue: TJSONNumber; +begin + jsonvalue := TJSONNumber.Create(value); + try + setParamValue(key, jsonvalue); + except + jsonvalue.Free; + end; +end; + +function TParamsFile.getValue(key: string; default: boolean): boolean; +var + jsonvalue: TJSONValue; +begin + jsonvalue := getParamValue(key); + if assigned(jsonvalue) then + result := jsonvalue.value.ToBoolean + else + result := default; +end; + +function TParamsFile.getValue(key: string; default: string): string; +var + jsonvalue: TJSONValue; +begin + jsonvalue := getParamValue(key); + if assigned(jsonvalue) then + result := jsonvalue.value + else + result := default; +end; + +function TParamsFile.getValue(key: string; default: integer): integer; +var + jsonvalue: TJSONValue; +begin + jsonvalue := getParamValue(key); + if assigned(jsonvalue) then + result := jsonvalue.value.ToInteger + else + result := default; +end; + +function TParamsFile.getValue(key: string; default: single): single; +var + jsonvalue: TJSONValue; +begin + jsonvalue := getParamValue(key); + if assigned(jsonvalue) then + result := jsonvalue.value.ToSingle + else + result := default; +end; + +function TParamsFile.AsJSONObject(AClone: boolean): TJSONObject; +begin + if not assigned(FParamList) then + result := nil + else if AClone then + result := FParamList.Clone as TJSONObject + else + result := FParamList; +end; + +constructor TParamsFile.Create; +begin + FFolderName := ''; + FParamChanged := False; + FParamList := TJSONObject.Create; +end; + +procedure TParamsFile.Cancel; +begin + Load; +end; + +constructor TParamsFile.Create(AFilePath: string); +begin + Create; + setFilePath(AFilePath, true); +end; + +destructor TParamsFile.Destroy; +begin + Save; + if assigned(FParamList) then + FreeAndNil(FParamList); + inherited; +end; + +function TParamsFile.getFilePath: string; +begin + result := getParamsFileName; +end; + +function TParamsFile.getValue(key: string; default: TDateTime): TDateTime; +var + jsonvalue: TJSONValue; +begin + jsonvalue := getParamValue(key); + if assigned(jsonvalue) then + result := strToDateTime(jsonvalue.value) + else + result := default; +end; + +procedure TParamsFile.Load; +var + filename: string; + buffer: tStringStream; +begin + filename := getParamsFileName; + if tfile.Exists(filename) then + begin + if assigned(FParamList) then + FreeAndNil(FParamList); + buffer := tStringStream.Create(tfile.ReadAllText(filename, TEncoding.UTF8), + TEncoding.UTF8); + try + FParamList := TJSONObject.Create; + FParamList.Parse(buffer.Bytes, 0); + finally + buffer.Free; + end; + end; +end; + +procedure TParamsFile.MoveToFilePath(ANewFilePath: string; ASave: boolean; + ACreateFolder: boolean); +var + oldFilePath: string; + NewPath: string; +begin + oldFilePath := getFilePath; + if (oldFilePath <> ANewFilePath) then + begin + NewPath := TPath.GetDirectoryName(ANewFilePath); + if not tdirectory.Exists(NewPath) then + if ACreateFolder then + tdirectory.CreateDirectory(NewPath) + else + raise Exception.Create('Folder "' + NewPath + '" doesn''t exist.'); + tfile.Move(oldFilePath, ANewFilePath); + setFilePath(ANewFilePath, False); + if ASave then + Save; + end; +end; + +procedure TParamsFile.Save; +var + filename: string; +begin + if (FParamChanged) then + begin + filename := getParamsFileName(true); + if assigned(FParamList) and (FParamList.Count > 0) then + tfile.WriteAllText(filename, FParamList.ToJSON, TEncoding.UTF8) + else if tfile.Exists(filename) then + tfile.Delete(filename); + FParamChanged := False; + end; +end; + +procedure TParamsFile.setValue(key: string; value: single); +var + jsonvalue: TJSONNumber; +begin + jsonvalue := TJSONNumber.Create(value); + try + setParamValue(key, jsonvalue); + except + jsonvalue.Free; + end; +end; + +procedure TParamsFile.setValue(key: string; value: TDateTime); +var + jsonvalue: TJSONString; +begin + jsonvalue := TJSONString.Create(DateTimeToStr(value)); + try + setParamValue(key, jsonvalue); + except + jsonvalue.Free; + end; +end; + +function TParamsFile.ToJSON: string; +begin + if assigned(FParamList) then + result := FParamList.ToJSON + else + result := ''; +end; + +procedure TParamsFile.setValue(key, value: string); +var + jsonvalue: TJSONString; +begin + jsonvalue := TJSONString.Create(value); + try + setParamValue(key, jsonvalue); + except + jsonvalue.Free; + end; +end; + +procedure TParamsFile.setValue(key: string; value: boolean); +var + jsonvalue: TJSONBool; +begin + jsonvalue := TJSONBool.Create(value); + try + setParamValue(key, jsonvalue); + except + jsonvalue.Free; + end; +end; + +procedure TParamsFile.setValue(key: string; value: integer); +var + jsonvalue: TJSONNumber; +begin + jsonvalue := TJSONNumber.Create(value); + try + setParamValue(key, jsonvalue); + except + jsonvalue.Free; + end; +end; + +procedure TParamsFile.setFilePath(AFilePath: string; AReload: boolean); +begin + if AFilePath.IsEmpty then + begin + FFolderName := ''; + FFileName := ''; + end + else + begin + FFolderName := TPath.GetDirectoryName(AFilePath); + if not tdirectory.Exists(FFolderName) then + raise Exception.Create('Folder "' + FFolderName + '" doesn''t exist.'); + FFileName := TPath.GetFileName(AFilePath); + end; + if AReload then + Load; +end; + +procedure TParamsFile.setFolderName(AFolderName: string; AReload: boolean); +begin + FFolderName := AFolderName; + if AReload then + Load; +end; + +function TParamsFile.getValue(key: string; default: TJSONValue): TJSONValue; +begin + result := getParamValue(key); + if not assigned(result) then + result := default; +end; + +function TParamsFile.getValue(key: string; default: cardinal): cardinal; +var + jsonvalue: TJSONValue; +begin + jsonvalue := getParamValue(key); + if assigned(jsonvalue) then + result := jsonvalue.value.ToInt64 + else + result := default; +end; + +procedure TParamsFile.setValue(key: string; value: TJSONValue); +begin + setParamValue(key, value); +end; + +{ TParams } + +var + DefaultParamsFile: TParamsFile; + +class function TParams.AsJSONObject: TJSONObject; +begin + result := DefaultParamsFile.AsJSONObject(true); +end; + +class function TParams.getFilePath: string; +begin + result := DefaultParamsFile.getFilePath; +end; + +class function TParams.getValue(key: string; default: integer): integer; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class function TParams.getValue(key: string; default: boolean): boolean; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class function TParams.getValue(key, default: string): string; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class function TParams.getValue(key: string; default: single): single; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class function TParams.getValue(key: string; default: TDateTime): TDateTime; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class procedure TParams.Load; +begin + DefaultParamsFile.Load; +end; + +class procedure TParams.MoveToFilePath(ANewFilePath: string; ASave: boolean; + ACreateFolder: boolean); +begin + DefaultParamsFile.MoveToFilePath(ANewFilePath, ASave, ACreateFolder); +end; + +class procedure TParams.Save; +begin + DefaultParamsFile.Save; +end; + +class procedure TParams.setFilePath(AFilePath: string; AReload: boolean); +begin + DefaultParamsFile.setFilePath(AFilePath, AReload); +end; + +class procedure TParams.setFolderName(AFolderName: string; AReload: boolean); +begin + DefaultParamsFile.setFolderName(AFolderName, AReload); +end; + +class procedure TParams.setValue(key: string; value: boolean); +begin + DefaultParamsFile.setValue(key, value); +end; + +class procedure TParams.setValue(key, value: string); +begin + DefaultParamsFile.setValue(key, value); +end; + +class procedure TParams.setValue(key: string; value: TDateTime); +begin + DefaultParamsFile.setValue(key, value); +end; + +class procedure TParams.setValue(key: string; value: single); +begin + DefaultParamsFile.setValue(key, value); +end; + +class procedure TParams.setValue(key: string; value: integer); +begin + DefaultParamsFile.setValue(key, value); +end; + +class function TParams.ToJSON: string; +begin + result := DefaultParamsFile.ToJSON; +end; + +class function TParams.getValue(key: string; default: TJSONValue): TJSONValue; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class function TParams.getValue(key: string; default: cardinal): integer; +begin + result := DefaultParamsFile.getValue(key, default); +end; + +class procedure TParams.setValue(key: string; value: TJSONValue); +begin + DefaultParamsFile.setValue(key, value); +end; + +class procedure TParams.setValue(key: string; value: cardinal); +begin + DefaultParamsFile.setValue(key, value); +end; + +initialization + +DefaultParamsFile := TParamsFile.Create; +TParams.Load; + +finalization + +TParams.Save; +if assigned(DefaultParamsFile) then + FreeAndNil(DefaultParamsFile); + +end. diff --git a/src/Olf.RTL.Streams.pas b/src/Olf.RTL.Streams.pas new file mode 100644 index 0000000..16009cb --- /dev/null +++ b/src/Olf.RTL.Streams.pas @@ -0,0 +1,106 @@ +unit Olf.RTL.Streams; + +interface + +uses + System.SysUtils, + System.Classes; + +procedure SaveStringToStream(AString: string; AStream: TStream); overload; +procedure SaveStringToStream(AString: string; AStream: TStream; + AEncoding: TEncoding); overload; + +function LoadStringFromStream(AStream: TStream): string; overload; +function LoadStringFromStream(AStream: TStream; AEncoding: TEncoding) + : string; overload; + +function LoadSubStreamFromStream(const AFromStream, AToSubStream + : TStream): boolean; +procedure SaveSubStreamToStream(const AFromSubStream, AToStream: TStream); + +implementation + +procedure SaveStringToStream(AString: string; AStream: TStream); +begin + SaveStringToStream(AString, AStream, TEncoding.UTF8); +end; + +procedure SaveStringToStream(AString: string; AStream: TStream; + AEncoding: TEncoding); +var + StrLen: int64; // typeof(System.Classes.TStream.size) + StrStream: TStringStream; +begin + StrStream := TStringStream.Create(AString, AEncoding); + try + StrLen := StrStream.Size; + AStream.write(StrLen, sizeof(StrLen)); + if (StrLen > 0) then + begin + StrStream.Position := 0; + AStream.CopyFrom(StrStream); + end; + finally + StrStream.Free; + end; +end; + +function LoadStringFromStream(AStream: TStream): string; +begin + Result := LoadStringFromStream(AStream, TEncoding.UTF8); +end; + +function LoadStringFromStream(AStream: TStream; AEncoding: TEncoding): string; +var + StrLen: int64; // typeof(System.Classes.TStream.size) + StrStream: TStringStream; +begin + AStream.Read(StrLen, sizeof(StrLen)); + if (StrLen > 0) then + begin + StrStream := TStringStream.Create('', AEncoding); + try + StrStream.CopyFrom(AStream, StrLen); + Result := StrStream.DataString; + finally + StrStream.Free; + end; + end + else + Result := ''; +end; + +function LoadSubStreamFromStream(const AFromStream, AToSubStream + : TStream): boolean; +var + Size: int64; +begin + if not assigned(AFromStream) then + raise exception.Create('Need a FromStream instance !'); + if not assigned(AToSubStream) then + raise exception.Create('Need a ToStream instance !'); + + Result := (AFromStream.ReadData(Size) = sizeof(Size)); + if Result then + AToSubStream.CopyFrom(AFromStream, Size); +end; + +procedure SaveSubStreamToStream(const AFromSubStream, AToStream: TStream); +var + Size: int64; +begin + if not assigned(AFromSubStream) then + raise exception.Create('Need a FromStream instance !'); + if not assigned(AToStream) then + raise exception.Create('Need a ToStream instance !'); + + Size := AFromSubStream.Size; + AToStream.WriteData(Size); + if (Size > 0) then + begin + AFromSubStream.Position := 0; + AToStream.CopyFrom(AFromSubStream, Size); + end; +end; + +end. diff --git a/src/Olf.RTL.SystemAppearance.pas b/src/Olf.RTL.SystemAppearance.pas new file mode 100644 index 0000000..d10c58c --- /dev/null +++ b/src/Olf.RTL.SystemAppearance.pas @@ -0,0 +1,102 @@ +unit Olf.RTL.SystemAppearance; + +interface + +function isSystemThemeInLightMode: boolean; +function isSystemThemeInDarkMode: boolean; + +implementation + +{$IF NOT Defined(MSWINDOWS)} + +uses + FMX.Platform; +{$ELSE} +// TODO : intercepter le changement de couleur du système et le signaler sous forme de message à l'application en cours + +uses + winapi.Windows, + System.Win.Registry; + +const + CRegKey = 'Software\Microsoft\Windows\CurrentVersion\Themes\Personalize'; + CRegValueApps = 'AppsUseLightTheme'; + CRegValueSystem = 'SystemUsesLightTheme'; +{$ENDIF} + +function isSystemThemeInLightMode: boolean; +{$IF NOT Defined(MSWINDOWS)} +var + InfoScreen: IFMXSystemAppearanceService; +{$ELSE} +var + reg: TRegistry; +{$ENDIF} +begin +{$IF NOT Defined(MSWINDOWS)} + if TPlatformServices.Current.SupportsPlatformService + (IFMXSystemAppearanceService, InfoScreen) then + result := (InfoScreen.ThemeKind = TSystemThemeKind.Light) + else + result := true; +{$ELSE} + // inspired by unit WindowsDarkMode.pas from Ian Barker at https://github.com/checkdigits/delphidarkmode + reg := TRegistry.Create(KEY_READ); + try + reg.RootKey := HKEY_CURRENT_USER; + if reg.KeyExists(CRegKey) and reg.OpenKey(CRegKey, False) then + try + if reg.ValueExists(CRegValueApps) then + result := reg.ReadInteger(CRegValueApps) = 1 + else if reg.ValueExists(CRegValueSystem) then + result := reg.ReadInteger(CRegValueApps) = 1 + else + result := true; + finally + reg.CloseKey; + end + else + result := true; + finally + reg.Free; + end; +{$ENDIF} +end; + +function isSystemThemeInDarkMode: boolean; +{$IF NOT Defined(MSWINDOWS)} +var + InfoScreen: IFMXSystemAppearanceService; +{$ELSE} +var + reg: TRegistry; +{$ENDIF} +begin +{$IF NOT Defined(MSWINDOWS)} + result := TPlatformServices.Current.SupportsPlatformService + (IFMXSystemAppearanceService, InfoScreen) and + (InfoScreen.ThemeKind = TSystemThemeKind.Dark); +{$ELSE} + reg := TRegistry.Create(KEY_READ); + try + reg.RootKey := HKEY_CURRENT_USER; + if reg.KeyExists(CRegKey) and reg.OpenKey(CRegKey, False) then + try + if reg.ValueExists(CRegValueApps) then + result := reg.ReadInteger(CRegValueApps) = 0 + else if reg.ValueExists(CRegValueSystem) then + result := reg.ReadInteger(CRegValueApps) = 0 + else + result := False; + finally + reg.CloseKey; + end + else + result := False; + finally + reg.Free; + end; +{$ENDIF} +end; + +end. diff --git a/src/Olf.VCL.Streams.pas b/src/Olf.VCL.Streams.pas new file mode 100644 index 0000000..7897aa3 --- /dev/null +++ b/src/Olf.VCL.Streams.pas @@ -0,0 +1,72 @@ +unit Olf.VCL.Streams; + +interface + +uses + VCL.Graphics, + System.SysUtils, + System.Classes; + +procedure SaveBitmapToStream(ABitmap: TBitmap; AToStream: TStream); +function LoadBitmapFromStream(AFromStream: TStream): TBitmap; + +implementation + +procedure SaveBitmapToStream(ABitmap: TBitmap; AToStream: TStream); +var + ms: TMemoryStream; + size: int64; +begin + if not assigned(AToStream) then + raise exception.create('Need an existing stream to save the bitmap !'); + + if not assigned(ABitmap) then + begin + size := 0; + AToStream.WriteData(size); + end + else + begin + ms := TMemoryStream.create; + try + ABitmap.SaveToStream(ms); + size := ms.size; + AToStream.WriteData(size); + if (size > 0) then + begin + ms.Position := 0; + AToStream.CopyFrom(ms, size); + end; + finally + ms.free; + end; + end; +end; + +function LoadBitmapFromStream(AFromStream: TStream): TBitmap; +var + ms: TMemoryStream; + size: int64; +begin + if not assigned(AFromStream) then + raise exception.create('Need an existing stream to load the bitmap !'); + + if (AFromStream.ReadData(size) <> sizeof(size)) then + result := nil + else if (size < 1) then + result := nil + else + begin + ms := TMemoryStream.create; + try + ms.CopyFrom(AFromStream, size); + ms.Position := 0; + result := TBitmap.create; + result.LoadFromStream(ms); + finally + ms.free; + end; + end; +end; + +end. \ No newline at end of file diff --git a/src/OlfSoftware_XML.dof b/src/OlfSoftware_XML.dof new file mode 100644 index 0000000..33600e0 --- /dev/null +++ b/src/OlfSoftware_XML.dof @@ -0,0 +1,89 @@ +[FileVersion] +Version=6.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=1 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=0 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription=XML Components from Olf Software +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath=$(DELPHI)\Lib\Debug +Packages=Vcl50;Vclx50;VclSmp50;Qrpt50;Vcldb50;Vclbde50;ibevnt50;vcldbx50;TeeUI50;TeeDB50;Tee50;TeeQR50;VCLIB50;vclie50;Inetdb50;Inet50;NMFast50;dclocx50;dclaxserver50 +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang=$0000040C +RootDir= +[Version Info] +IncludeVerInfo=1 +AutoIncBuild=1 +MajorVer=1 +MinorVer=0 +Release=0 +Build=2 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1036 +CodePage=1252 +[Version Info Keys] +CompanyName=Netbusiness +FileDescription= +FileVersion=1.0.0.2 +InternalName= +LegalCopyright=Netbusiness 2001 +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= +[Excluded Packages] +c:\program files\borland\delphi6\Projects\Bpl\OlfSoftware_XML.bpl=XML Components from Olf Software diff --git a/src/OlfSoftware_XML.dpk b/src/OlfSoftware_XML.dpk new file mode 100644 index 0000000..c60f14b --- /dev/null +++ b/src/OlfSoftware_XML.dpk @@ -0,0 +1,35 @@ +package OlfSoftware_XML; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'XML Components from Olf Software'} +{$IMPLICITBUILD OFF} + +requires + vcl, + microsoft_xml; + +contains + XML_as_List in 'XML_as_List.pas'; + +end. diff --git a/src/XML_as_List.pas b/src/XML_as_List.pas new file mode 100644 index 0000000..dc9645d --- /dev/null +++ b/src/XML_as_List.pas @@ -0,0 +1,166 @@ +unit XML_as_List; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, MSXML_TLB; + +type + TXML_as_List = class(TComponent) + private + { Déclarations privées } + fActive: Boolean; + fFileName: WideString; + fDocument: TDOMDocument; + fNoeud_Actuel : IXMLDOMNode; + procedure Set_Active(const Value: Boolean); + procedure Set_FileName(const Value: WideString); + protected + { Déclarations protégées } + public + { Déclarations publiques } + function Bof: boolean; + procedure Close; + constructor Create (AOwner: TComponent); override; + function Eof: boolean; + function FieldByName_AsString (FieldName: WideString): WideString; + function FieldByName_AsInteger (FieldName: WideString): Int64; + function FieldByName_AsFloat (FieldName: WideString): Extended; + procedure First; + procedure Last; + procedure Next; + function Open (FileName: WideString): boolean; + procedure Previous; + published + { Déclarations publiées } + property Active : Boolean read fActive write Set_Active default false; + property FileName : WideString read fFileName write Set_FileName; + end; + +procedure Register; + +implementation + +procedure Register; +begin + RegisterComponents('OlfSoftware', [TXML_as_List]); +end; + +{ TXML_as_List } + +function TXML_as_List.Bof: boolean; +begin + Result := (fNoeud_Actuel = nil); +end; + +procedure TXML_as_List.Close; +begin + Active := False; +end; + +constructor TXML_as_List.Create(AOwner: TComponent); +begin + inherited; + fDocument := TDOMDocument.Create (Self); + fNoeud_Actuel := nil; +end; + +function TXML_as_List.Eof: boolean; +begin + Result := (fNoeud_Actuel = nil); +end; + +function TXML_as_List.FieldByName_AsFloat(FieldName: WideString): Extended; +begin + try + Result := StrToFloat (FieldByName_AsString (FieldName)); + except + Result := 0; + end; +end; + +function TXML_as_List.FieldByName_AsInteger( + FieldName: WideString): Int64; +begin + try + Result := StrToInt64 (FieldByName_AsString (FieldName)); + except + Result := 0; + end; +end; + +function TXML_as_List.FieldByName_AsString( + FieldName: WideString): WideString; +var + noeud: IXMLDOMNode; +begin + if (fNoeud_Actuel <> nil) then begin + noeud := fNoeud_Actuel.firstChild; + while ((noeud <> nil) and (LowerCase (noeud.baseName) <> LowerCase (FieldName))) do + noeud := noeud.nextSibling; + {endwhile} + if (noeud <> nil) then + Result := noeud.text + else + Result := ''; + {endif} + end else + Result := ''; + {endif} +end; + +procedure TXML_as_List.First; +begin + if (fActive) then + fNoeud_Actuel := fDocument.documentElement.firstChild; + {endif} +end; + +procedure TXML_as_List.Last; +begin + if (fActive) then + fNoeud_Actuel := fDocument.documentElement.lastChild; + {endif} +end; + +procedure TXML_as_List.Next; +begin + fNoeud_Actuel := fNoeud_Actuel.nextSibling; +end; + +function TXML_as_List.Open(FileName: WideString): boolean; +begin + if fActive then + fActive := False; + {endif} + if (fDocument.load (FileName)) then begin + fFileName := FileName; + fActive := True; + First; + end; + Result := fActive; +end; + +procedure TXML_as_List.Previous; +begin + fNoeud_Actuel := fNoeud_Actuel.previousSibling; +end; + +procedure TXML_as_List.Set_Active(const Value: Boolean); +begin + if (Value <> fActive) then begin + fActive := Value; + if (Value) then + Open (fFileName) + else + fNoeud_Actuel := nil; + {endif} + end; +end; + +procedure TXML_as_List.Set_FileName(const Value: WideString); +begin + fFileName := Value; +end; + +end. diff --git a/src/f_operation_en_cours.dfm b/src/f_operation_en_cours.dfm new file mode 100644 index 0000000000000000000000000000000000000000..f923893187bcc9119a7fc82c3467b46b473c645c GIT binary patch literal 461 zcmYk2-%i3X6vn#^*kA)qH1R?&_5=nW0VWG3AcWR%X-an(O-j48HNqqL6khmDUhDpV z@uJE3&gqvgzwf7qNV=M%;pL};5Lu?f7TM~(SH9K^w${6IJfaFW564Pppr4qMCPXKN z?NNXqYz*cyFQ zR?l<~o&Frhm`W34(0tqYYl0A!zx2ML3AYAYdR)j7J6I~iD+GT~D9ki~OiBRI9n7eJ zEa+8%r>H)P$Wp6ZgE3>Oqkr>5-KC4_DpC7P+&MSV9toaHKcJ$iq=hXMt`iWtSyZjN Vs6ROrf-`O#@2xX9FaFXI`UOO*kjwx8 literal 0 HcmV?d00001 diff --git a/src/f_operation_en_cours.pas b/src/f_operation_en_cours.pas new file mode 100644 index 0000000..f928e9e --- /dev/null +++ b/src/f_operation_en_cours.pas @@ -0,0 +1,91 @@ +unit f_operation_en_cours; + +interface + +uses System.Classes, Vcl.Controls, Vcl.ComCtrls; + +Procedure oec_Ouverture(nb_operation: cardinal); +Procedure oec_Operation_Suivante; +Procedure oec_Fermeture; + +implementation + +{$R *.DFM} + +uses + Windows, Messages, SysUtils, Graphics, Forms, Dialogs; + +type + Tfrm = class(TForm) + ProgressBar1: TProgressBar; + private + { Déclarations privées } + public + { Déclarations publiques } + end; + +var + frm: Tfrm; + +Procedure oec_Ouverture(nb_operation: cardinal); +begin + if (frm = nil) then + frm := Tfrm.Create(Nil); + try + frm.ProgressBar1.Min := 0; + frm.ProgressBar1.Max := nb_operation; + frm.ProgressBar1.Position := 0; + frm.Show; + except + try + frm.Free; + finally + frm := nil; + end; + end; +end; + +Procedure oec_Operation_Suivante; +begin + if (frm = nil) then + oec_Ouverture(0); + try + frm.ProgressBar1.StepIt; + except + try + frm.Free; + finally + frm := nil; + end; + end; +end; + +Procedure oec_Fermeture; +begin + if (frm = nil) then + oec_Ouverture(0); + try + frm.Hide; + except + try + frm.Free; + finally + frm := nil; + end; + end; +end; + +initialization + +frm := nil; + +finalization + +if (frm <> nil) then +begin + frm.Free; + frm := nil; +end; + +{ endif } +end. diff --git a/src/imports/AgentObjects_TLB.dcr b/src/imports/AgentObjects_TLB.dcr new file mode 100644 index 0000000000000000000000000000000000000000..11bc6a04c3a8887f1c7e26111382f299b517db70 GIT binary patch literal 308 zcmZvWu?<2o3`7rvlyv`(KuN(86o`(BLEO1bnXxhsWi~K(iBceaE9ZCiMNt6YN<~c3 z{?(V$or*Z)g9l!C;!U?|-K%oE+Z(TA2lWlOPOG&r3zYW4D=x(CfMg61LoGz yJ$W)9adL}|GklBaj*95KUTX`r_$7$p>8Bx%mZ})LXq<;3|RaO?GqT-rE;s{=JbT@>DyE!C|;N8BRi;|Kohr|)Q zA$%jKGkPI zK>_0Y{gI!XY_mQEPel4~y_XkEH8n78-HNSKUPTAub>q0{y^(nJlpR34D==^IJlwr| z7xAp)^>gR!9xp0p-TnK@yWjsO5yr!dkaaN&Z*b z^2A|06<5OO^k^6&4LEe=5Zo)=;S}nG5q~ql^y#Nc`H6{%=-IO;3`~|R;@yMdO99Ieryw-jN{f2Z5x`4Q;%#GTcuop@SOn8DJ|a_jL~E|{$x5sm6#71 zkUvG((C?WC`TF{@B~Py)+R5g0;AmcLZEYj}88>bmJW^9}#$*DPEdxIJ1Qp_U_$_WZHU1 zMC#zqHR*GfAI9~jCv8CB<;z&hwDY1xSj=!T*94MOv(OIq>C*?IV|zs!BY5lCo<$os zVmZt1e&GU!v+nI^Z=IPAx_%vC93OuSyz>smPoIu6XU?FwxY#a{cT_y#lAWlxZscYx z42X*ZrcT9+?6)mkSMkzIK!*;>^PZlbI8FUq>lG%QP^&WX+5spO200ZIfhY?`VQ2`o_S4c=gmN z7&$%`(?|Rxea2yvCgDY>7?4>4oLAT`x!lU%)O9$TtDrG2p(8Sv%$1p0^Q-5dU# z6JHU>nf~c;`nVW5QpuNllV;C`_>$Jfp|yN1UJb{~S&qT8^eY3lZ9`09A%+r9v1g)7 z+S4IJh9D&+Me#*cU&~tA&E;$HwD+qx{)c`0E!t3*;P@2jKWGs9D(5$LGlO~&ZX}YF zl=RFtTfOjKl=<7 zY_lzRqLV{hBM#Em2oI2YejV%$W6A=!r2=1PnR$_saqOnQu`>Y9Va^JkJX={=iBxio zl!XiN8L0`2ClTelQE6K#9anSUTD&y2-l@$XXd%IQGh z@;+!2)}|3pxa|Jr%aOKb4gPuj_;c|Dzm7cUTx={7SjRHW_wL=p4_|zN6YPrzjN775wY}2LlYB4xn{Qwu*D-bJ0@rmwn?erLrNHXb z#C=HV$+Qc*mUS%Tchmj!L8MQl9DDFoTs7>mxd)2Mi?B9*Ejr|KU0g*~g#p=rlCkQ6 zde-k6?T1$O@855eK2;3MP`J>?To_jsR$$seDk{t;f`iT2K{s?T`{rSD@{pg%W z=RB62Nas8{=dp$N=$uFAJUZvmIS;*{Ccc>JN>23>Nx`a zT$_Hb?OA8s^mA?cxiRrJrkix~8amO0u5l=i2mhZO=RZr5!J-4`OR5doDWP H5x(