├── AEFrameworkReg.pas ├── AE.Updater ├── AE.Comp.Updater.FileProvider.Flat.pas ├── AE.Comp.Updater.FileProvider.Custom.pas ├── AE.Comp.Updater.FileProvider.pas ├── AE.Comp.Updater.FileProvider.HTTP.pas └── AE.Comp.Updater.pas ├── AE.Misc ├── AE.Misc.UnixTimestamp.pas ├── AE.DLL.Loader.pas ├── AE.DLL.AutoLoader.pas ├── AE.Misc.Random.pas ├── AE.Misc.FileUtils.pas ├── AE.MNB.ExchangeRates.pas ├── AE.Helper.TBytes.pas ├── MNB.ExchangeRate.SoapService.pas └── AE.DDEManager.pas ├── AE.Application ├── AE.Application.Helper.pas ├── AE.Application.Setting.pas ├── AE.Application.Application.pas ├── AE.Application.Console.pas ├── AE.Application.Settings.pas └── AE.Application.Engine.pas ├── AE.IDE ├── AE.IDE.Versions.Consts.pas ├── AE.IDE.DelphiVersions.pas ├── AE.IDE.VSVersions.pas └── AE.IDE.Versions.pas ├── AEFramework_R.dpk ├── AEFramework.groupproj ├── .gitignore ├── AEFramework_D.dpk ├── AE.VirtualKeyboard ├── AE.VirtualKeyboard.Foreign.pas ├── AE.VirtualKeyboard.EnUs.pas ├── AE.VirtualKeyboard.pas └── AE.VirtualKeyboard.HuHu.pas ├── AE.Comp ├── AE.Comp.HeaderMenuItem.pas ├── AE.Comp.MenuTreeParser.pas ├── AE.Comp.ComboBox.pas ├── AE.Comp.ThreadedTimer.pas ├── AE.Comp.KeepMeAwake.pas └── AE.Comp.TagEditor.pas ├── README.md └── 3rdParty └── OSVersion.pas /AEFrameworkReg.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AEFrameworkReg; 10 | 11 | Interface 12 | 13 | Procedure Register; 14 | 15 | Implementation 16 | 17 | Uses System.Classes, AE.Comp.HeaderMenuItem, AE.Comp.PageControl, AE.Comp.ComboBox, AE.Comp.ThreadedTimer, AE.Comp.Updater, 18 | AE.Comp.DBGrid, AE.Comp.Updater.FileProvider.HTTP, AE.Comp.Updater.FileProvider.Flat, AE.Comp.Updater.FileProvider.Custom, 19 | AE.MNB.ExchangeRates, AE.Comp.KeepMeAwake, AE.Comp.MenuTreeParser, AE.Comp.TagEditor; 20 | 21 | Procedure Register; 22 | Begin 23 | RegisterComponents('AE Components', [TAEHeaderMenuItem, TAEPageControl, TAEComboBox, TAEThreadedTimer, TAEDBGrid, TAEMNBExchangeRates, TAEKeepMeAwake, TAEMenuTreeParser, TAETagEditor]); 24 | RegisterComponents('AE Updater components', [TAEUpdater, TAEUpdaterHTTPFileProvider, TAEUpdaterFlatFileProvider, TAEUpdaterCustomFileProvider]); 25 | 26 | // RegisterComponentEditor(TMyComponent, TMyEditor); 27 | End; 28 | 29 | End. 30 | -------------------------------------------------------------------------------- /AE.Updater/AE.Comp.Updater.FileProvider.Flat.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.Updater.FileProvider.Flat; 10 | 11 | Interface 12 | 13 | Uses AE.Comp.Updater.FileProvider, System.Classes; 14 | 15 | Type 16 | TAEUpdaterFlatFileProvider = Class(TAEUpdaterFileProvider) 17 | strict protected 18 | Procedure InternalProvideFile(Const inFileName: String; Const outStream: TStream); Override; 19 | Function InternalUpdateRoot: String; Override; 20 | End; 21 | 22 | Implementation 23 | 24 | Uses System.SysUtils, System.IOUtils; 25 | 26 | Procedure TAEUpdaterFlatFileProvider.InternalProvideFile(Const inFileName: String; Const outStream: TStream); 27 | Var 28 | fs: TFileStream; 29 | Begin 30 | fs := TFileStream.Create(inFileName, fmOpenRead + fmShareDenyWrite); 31 | Try 32 | outStream.CopyFrom(fs, fs.Size); 33 | Finally 34 | FreeAndNil(fs); 35 | End; 36 | End; 37 | 38 | Function TAEUpdaterFlatFileProvider.InternalUpdateRoot: String; 39 | Begin 40 | Result := Self.UpdateFileName.Substring(0, Self.UpdateFileName.LastIndexOf(TPath.DirectorySeparatorChar) + 1); 41 | End; 42 | 43 | End. 44 | -------------------------------------------------------------------------------- /AE.Misc/AE.Misc.UnixTimestamp.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Misc.UnixTimestamp; 10 | 11 | Interface 12 | 13 | Function DateToUnix(Const inDateTime: TDateTime; 14 | Const inConvertToUTC: Boolean = True): UInt64; 15 | Function UnixToDate(Const inUnix: UInt64; 16 | Const inConvertFromUTC: Boolean = True): TDateTime; 17 | 18 | Implementation 19 | 20 | Uses System.DateUtils; 21 | 22 | // Delphi's implementation expects to be told if the supplied date is in UTC already or not. 23 | // It will NOT add the timezone AND daylight saving offset if the incoming parameter is True. 24 | // 25 | // Therefore, if we want to convert, we have to send False, if we don't, True; this is why 26 | // we are inverting our incoming variables 27 | 28 | Function DateToUnix(Const inDateTime: TDateTime; 29 | Const inConvertToUTC: Boolean = True): UInt64; 30 | Begin 31 | Result := DateTimeToUnix(inDateTime, Not inConvertToUTC); 32 | End; 33 | 34 | Function UnixToDate(Const inUnix: UInt64; 35 | Const inConvertFromUTC: Boolean = True): TDateTime; 36 | Begin 37 | Result := UnixToDateTime(inUnix, Not inConvertFromUTC); 38 | End; 39 | 40 | End. 41 | -------------------------------------------------------------------------------- /AE.Application/AE.Application.Helper.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Application.Helper; 10 | 11 | Interface 12 | 13 | Uses System.SysUtils; 14 | 15 | Type 16 | TLogProcedure = Procedure(inMessageToLog: String) Of Object; 17 | TProcedureOfObject = Procedure Of Object; 18 | TErrorHandler = Procedure(inException: Exception) Of Object; 19 | TLogDateFormat = (dfNone, dfSystemDefault, dfNormal, dfDebug); 20 | EAEApplicationException = Class(Exception); 21 | 22 | Const 23 | POLLINTERVAL = 100; 24 | 25 | {$IFDEF MSWINDOWS} 26 | Procedure CustomMessagePump; 27 | {$ENDIF} 28 | 29 | Implementation 30 | 31 | {$IFDEF MSWINDOWS} 32 | Uses WinApi.Windows; 33 | 34 | Procedure CustomMessagePump; 35 | Var 36 | msg: TagMsg; 37 | Begin 38 | // TWSocket, TClientSocket and TServerSocket is using the forms message pump to 39 | // fire off events in non-blocking mode. In a worker thread there are no forms and 40 | // so we have to create a message pump for ourselves 41 | While PeekMessage(msg, 0, 0, 0, 0) Do 42 | Begin 43 | GetMessage(msg, 0, 0, 0); 44 | TranslateMessage(msg); 45 | DispatchMessage(msg); 46 | End; 47 | End; 48 | {$ENDIF} 49 | 50 | End. 51 | -------------------------------------------------------------------------------- /AE.IDE/AE.IDE.Versions.Consts.pas: -------------------------------------------------------------------------------- 1 | Unit AE.IDE.Versions.Consts; 2 | 3 | Interface 4 | 5 | Const 6 | IDEVER_DELPHI6 = 'Borland Delphi 6'; 7 | IDEVER_DELPHI7 = 'Borland Delphi 7'; 8 | IDEVER_DELPHI2005 = 'Borland Delphi 2005'; 9 | IDEVER_DELPHI2006 = 'Borland Delphi 2006'; 10 | IDEVER_DELPHI2007 = 'Borland Delphi 2007'; 11 | IDEVER_DELPHI2009 = 'CodeGear Delphi 2009'; 12 | IDEVER_DELPHI2010 = 'CodeGear Delphi 2010'; 13 | IDEVER_DELPHIXE = 'Embarcadero Delphi XE'; 14 | IDEVER_DELPHIXE2 = 'Embarcadero Delphi XE2'; 15 | IDEVER_DELPHIXE3 = 'Embarcadero Delphi XE3'; 16 | IDEVER_DELPHIXE4 = 'Embarcadero Delphi XE4'; 17 | IDEVER_DELPHIXE5 = 'Embarcadero Delphi XE5'; 18 | IDEVER_DELPHIXE6 = 'Embarcadero Delphi XE6'; 19 | IDEVER_DELPHIXE7 = 'Embarcadero Delphi XE7'; 20 | IDEVER_DELPHIXE8 = 'Embarcadero Delphi XE8'; 21 | IDEVER_DELPHI10 = 'Embarcadero Delphi 10 Seattle'; 22 | IDEVER_DELPHI101 = 'Embarcadero Delphi 10.1 Berlin'; 23 | IDEVER_DELPHI102 = 'Embarcadero Delphi 10.2 Tokyo'; 24 | IDEVER_DELPHI103 = 'Embarcadero Delphi 10.3 Rio'; 25 | IDEVER_DELPHI104 = 'Embarcadero Delphi 10.4 Sydney'; 26 | IDEVER_DELPHI11 = 'Embarcadero Delphi 11 Alexandria'; 27 | IDEVER_DELPHI12 = 'Embarcadero Delphi 12 Athens'; 28 | 29 | IDEVER_VS2005 = 'Microsoft Visual Studio 2005'; 30 | IDEVER_VS2008 = 'Microsoft Visual Studio 2008'; 31 | IDEVER_VS2010 = 'Microsoft Visual Studio 2010'; 32 | IDEVER_VS2012 = 'Microsoft Visual Studio 2012'; 33 | IDEVER_VS2013 = 'Microsoft Visual Studio 2013'; 34 | IDEVER_VS2015 = 'Microsoft Visual Studio 2015'; 35 | IDEVER_VS2017 = 'Microsoft Visual Studio 2017'; 36 | IDEVER_VS2019 = 'Microsoft Visual Studio 2019'; 37 | IDEVER_VS2022 = 'Microsoft Visual Studio 2022'; 38 | 39 | Implementation 40 | 41 | End. 42 | -------------------------------------------------------------------------------- /AEFramework_R.dpk: -------------------------------------------------------------------------------- 1 | package AEFramework_R; 2 | 3 | {$R *.res} 4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 5 | {$ALIGN 8} 6 | {$ASSERTIONS ON} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO OFF} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS ON} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION OFF} 16 | {$OVERFLOWCHECKS ON} 17 | {$RANGECHECKS ON} 18 | {$REFERENCEINFO ON} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES ON} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DEFINE DEBUG} 27 | {$ENDIF IMPLICITBUILDING} 28 | {$DESCRIPTION 'AE Framework Runtime Package'} 29 | {$LIBSUFFIX AUTO} 30 | {$RUNONLY} 31 | {$IMPLICITBUILD ON} 32 | 33 | requires 34 | rtl, 35 | xmlrtl, 36 | soaprtl, 37 | dbrtl, 38 | inet; 39 | 40 | contains 41 | OSVersion in '3rdParty\OSVersion.pas', 42 | AE.Application.Helper in 'AE.Application\AE.Application.Helper.pas', 43 | AE.Application.Setting in 'AE.Application\AE.Application.Setting.pas', 44 | AE.Application.Settings in 'AE.Application\AE.Application.Settings.pas', 45 | AE.Application.Application in 'AE.Application\AE.Application.Application.pas', 46 | AE.Application.Console in 'AE.Application\AE.Application.Console.pas', 47 | AE.Application.Engine in 'AE.Application\AE.Application.Engine.pas', 48 | AE.Helper.TBytes in 'AE.Misc\AE.Helper.TBytes.pas', 49 | AE.Misc.Random in 'AE.Misc\AE.Misc.Random.pas', 50 | AE.Misc.UnixTimestamp in 'AE.Misc\AE.Misc.UnixTimestamp.pas', 51 | AE.MNB.ExchangeRates in 'AE.Misc\AE.MNB.ExchangeRates.pas', 52 | MNB.ExchangeRate.SoapService in 'AE.Misc\MNB.ExchangeRate.SoapService.pas', 53 | AE.Comp.MenuTreeParser in 'AE.Comp\AE.Comp.MenuTreeParser.pas', 54 | AE.DLL.Loader in 'AE.Misc\AE.DLL.Loader.pas', 55 | AE.DLL.AutoLoader in 'AE.Misc\AE.DLL.AutoLoader.pas'; 56 | 57 | end. 58 | -------------------------------------------------------------------------------- /AEFramework.groupproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {9C01C9D4-B8C4-466B-A320-F8D37162E1A7} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | Default.Personality.12 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | *.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | Private/ 64 | *.~* 65 | 66 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 67 | *.stat 68 | 69 | # Boss dependency manager vendor folder https://github.com/HashLoad/boss 70 | modules/ 71 | -------------------------------------------------------------------------------- /AE.Application/AE.Application.Setting.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Application.Setting; 10 | 11 | Interface 12 | 13 | Uses System.JSON; 14 | 15 | Type 16 | TAEApplicationSetting = Class 17 | strict protected 18 | Procedure InternalClear; Virtual; 19 | Procedure SetAsJSON(Const inJSON: TJSONObject); Virtual; 20 | Function GetAsJSON: TJSONObject; Virtual; 21 | public 22 | Class Function NewFromJSON(Const inJSON: TJSONValue): TAEApplicationSetting; 23 | Constructor Create; ReIntroduce; Virtual; 24 | Procedure AfterConstruction; Override; 25 | Procedure Clear; 26 | Property AsJSON: TJSONObject Read GetAsJSON Write SetAsJSON; 27 | End; 28 | 29 | Implementation 30 | 31 | Uses System.SysUtils; 32 | 33 | Procedure TAEApplicationSetting.AfterConstruction; 34 | Begin 35 | inherited; 36 | 37 | Self.InternalClear; 38 | End; 39 | 40 | Procedure TAEApplicationSetting.Clear; 41 | Begin 42 | Self.InternalClear; 43 | End; 44 | 45 | Constructor TAEApplicationSetting.Create; 46 | Begin 47 | inherited; 48 | End; 49 | 50 | Function TAEApplicationSetting.GetAsJSON: TJSONObject; 51 | Begin 52 | Result := TJSONObject.Create; 53 | End; 54 | 55 | Procedure TAEApplicationSetting.InternalClear; 56 | Begin 57 | // Dummy 58 | End; 59 | 60 | Class Function TAEApplicationSetting.NewFromJSON(Const inJSON: TJSONValue): TAEApplicationSetting; 61 | Begin 62 | Result := Self.Create; 63 | Try 64 | Result.AsJSON := TJSONObject(inJSON); 65 | Except 66 | On E: Exception Do 67 | Begin 68 | FreeAndNil(Result); 69 | Raise; 70 | End; 71 | End; 72 | End; 73 | 74 | Procedure TAEApplicationSetting.SetAsJSON(Const inJSON: TJSONObject); 75 | Begin 76 | Self.InternalClear; 77 | End; 78 | 79 | End. 80 | -------------------------------------------------------------------------------- /AE.Application/AE.Application.Application.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Application.Application; 10 | 11 | Interface 12 | 13 | Uses AE.Application.Helper; 14 | 15 | Type 16 | TAEApplication = Class 17 | strict private 18 | _osshutdown: Boolean; 19 | _logprocedure: TLogProcedure; 20 | strict protected 21 | LogDateFormat: TLogDateFormat; 22 | Procedure Log(inMessage: String); 23 | Procedure Creating; Virtual; 24 | Procedure Destroying; Virtual; 25 | public 26 | Constructor Create(inLogProcedure: TLogProcedure); ReIntroduce; 27 | Destructor Destroy; Override; 28 | Property OSShutdown: Boolean Read _osshutdown Write _osshutdown; 29 | End; 30 | 31 | TAEApplicationClass = Class Of TAEApplication; 32 | 33 | Implementation 34 | 35 | Uses System.SysUtils; 36 | 37 | Constructor TAEApplication.Create(inLogProcedure: TLogProcedure); 38 | Begin 39 | inherited Create; 40 | {$IFDEF DEBUG} 41 | LogDateFormat := dfDebug; 42 | ReportMemoryLeaksOnShutdown := True; 43 | {$ELSE} 44 | LogDateFormat := dfSystemDefault; 45 | {$ENDIF} 46 | _logprocedure := inLogProcedure; 47 | _osshutdown := False; 48 | Self.Creating; 49 | End; 50 | 51 | Procedure TAEApplication.Creating; 52 | Begin 53 | // Dummy 54 | End; 55 | 56 | Destructor TAEApplication.Destroy; 57 | Begin 58 | Self.Destroying; 59 | inherited; 60 | End; 61 | 62 | Procedure TAEApplication.Destroying; 63 | Begin 64 | // Dummy 65 | End; 66 | 67 | Procedure TAEApplication.Log(inMessage: String); 68 | Var 69 | datetime: String; 70 | Begin 71 | If Assigned(_logprocedure) Then 72 | Begin 73 | Case LogDateFormat Of 74 | dfNone: 75 | datetime := ''; 76 | dfSystemDefault: 77 | datetime := DateTimeToStr(Now) + ' - '; 78 | dfNormal: 79 | datetime := FormatDateTime('yyyy.mm.dd hh:nn:ss', Now) + ' - '; 80 | dfDebug: 81 | datetime := FormatDateTime('yyyy.mm.dd hh:nn:ss.zzzz', Now) + ' - '; 82 | End; 83 | _logprocedure(datetime + inMessage); 84 | End; 85 | End; 86 | 87 | End. 88 | -------------------------------------------------------------------------------- /AE.Updater/AE.Comp.Updater.FileProvider.Custom.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.Updater.FileProvider.Custom; 10 | 11 | Interface 12 | 13 | Uses AE.Comp.Updater.FileProvider, System.Classes; 14 | 15 | Type 16 | TCustomFileProviderGetUpdateRootEvent = Procedure(Sender: TObject; Var outUpdateRoot: String) Of Object; 17 | TCustomFileProviderProvideFileEvent = Procedure(Sender: TObject; Const inFileName: String; Const outStream: TStream) Of Object; 18 | 19 | TAEUpdaterCustomFileProvider = Class(TAEUpdaterFileProvider) 20 | strict private 21 | _ongetupdateroot: TCustomFileProviderGetUpdateRootEvent; 22 | _onprovidefile: TCustomFileProviderProvideFileEvent; 23 | _onresetcache: TNotifyEvent; 24 | strict protected 25 | Procedure InternalProvideFile(Const inFileName: String; Const outStream: TStream); Override; 26 | Procedure InternalResetCache; Override; 27 | Function InternalUpdateRoot: String; Override; 28 | public 29 | Constructor Create(AOwner: TComponent); Override; 30 | published 31 | Property OnGetUpdateRoot: TCustomFileProviderGetUpdateRootEvent Read _ongetupdateroot Write _ongetupdateroot; 32 | Property OnProvideFile: TCustomFileProviderProvideFileEvent Read _onprovidefile Write _onprovidefile; 33 | Property OnResetCache: TNotifyEvent Read _onresetcache Write _onresetcache; 34 | End; 35 | 36 | Implementation 37 | 38 | Constructor TAEUpdaterCustomFileProvider.Create(AOwner: TComponent); 39 | Begin 40 | inherited; 41 | 42 | _ongetupdateroot := nil; 43 | _onprovidefile := nil; 44 | _onresetcache := nil; 45 | End; 46 | 47 | Procedure TAEUpdaterCustomFileProvider.InternalProvideFile(Const inFileName: String; Const outStream: TStream); 48 | Begin 49 | inherited; 50 | 51 | If Assigned(_onprovidefile) Then 52 | _onprovidefile(Self, inFileName, outStream); 53 | End; 54 | 55 | Procedure TAEUpdaterCustomFileProvider.InternalResetCache; 56 | Begin 57 | If Assigned(_onresetcache) Then 58 | _onresetcache(Self); 59 | End; 60 | 61 | Function TAEUpdaterCustomFileProvider.InternalUpdateRoot: String; 62 | Begin 63 | Result := ''; 64 | 65 | If Assigned(_ongetupdateroot) Then 66 | _ongetupdateroot(Self, Result); 67 | End; 68 | 69 | End. 70 | -------------------------------------------------------------------------------- /AEFramework_D.dpk: -------------------------------------------------------------------------------- 1 | package AEFramework_D; 2 | 3 | {$R *.res} 4 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 5 | {$ALIGN 8} 6 | {$ASSERTIONS ON} 7 | {$BOOLEVAL OFF} 8 | {$DEBUGINFO OFF} 9 | {$EXTENDEDSYNTAX ON} 10 | {$IMPORTEDDATA ON} 11 | {$IOCHECKS ON} 12 | {$LOCALSYMBOLS ON} 13 | {$LONGSTRINGS ON} 14 | {$OPENSTRINGS ON} 15 | {$OPTIMIZATION OFF} 16 | {$OVERFLOWCHECKS ON} 17 | {$RANGECHECKS ON} 18 | {$REFERENCEINFO ON} 19 | {$SAFEDIVIDE OFF} 20 | {$STACKFRAMES ON} 21 | {$TYPEDADDRESS OFF} 22 | {$VARSTRINGCHECKS ON} 23 | {$WRITEABLECONST OFF} 24 | {$MINENUMSIZE 1} 25 | {$IMAGEBASE $400000} 26 | {$DEFINE DEBUG} 27 | {$ENDIF IMPLICITBUILDING} 28 | {$DESCRIPTION 'AE Framework Design Time package'} 29 | {$LIBSUFFIX AUTO} 30 | {$IMPLICITBUILD ON} 31 | 32 | requires 33 | rtl, 34 | vcl, 35 | vclwinx, 36 | dbrtl, 37 | vcldb, 38 | vclx, 39 | xmlrtl, 40 | soaprtl, 41 | inet; 42 | 43 | contains 44 | AE.Comp.PageControl in 'AE.Comp\AE.Comp.PageControl.pas', 45 | AE.Comp.ThreadedTimer in 'AE.Comp\AE.Comp.ThreadedTimer.pas', 46 | AE.Misc.FileUtils in 'AE.Misc\AE.Misc.FileUtils.pas', 47 | AE.Comp.ComboBox in 'AE.Comp\AE.Comp.ComboBox.pas', 48 | AE.Comp.HeaderMenuItem in 'AE.Comp\AE.Comp.HeaderMenuItem.pas', 49 | AEFrameworkReg in 'AEFrameworkReg.pas', 50 | AE.Comp.Updater in 'AE.Updater\AE.Comp.Updater.pas', 51 | AE.Comp.DBGrid in 'AE.Comp\AE.Comp.DBGrid.pas', 52 | AE.Comp.Updater.FileProvider in 'AE.Updater\AE.Comp.Updater.FileProvider.pas', 53 | AE.Comp.Updater.FileProvider.HTTP in 'AE.Updater\AE.Comp.Updater.FileProvider.HTTP.pas', 54 | AE.Comp.Updater.FileProvider.Flat in 'AE.Updater\AE.Comp.Updater.FileProvider.Flat.pas', 55 | AE.Comp.Updater.FileProvider.Custom in 'AE.Updater\AE.Comp.Updater.FileProvider.Custom.pas', 56 | AE.Comp.Updater.UpdateFile in 'AE.Updater\AE.Comp.Updater.UpdateFile.pas', 57 | AE.DDEManager in 'AE.Misc\AE.DDEManager.pas', 58 | AE.IDE.DelphiVersions in 'AE.IDE\AE.IDE.DelphiVersions.pas', 59 | AE.IDE.Versions in 'AE.IDE\AE.IDE.Versions.pas', 60 | AE.IDE.VSVersions in 'AE.IDE\AE.IDE.VSVersions.pas', 61 | AE.IDE.Versions.Consts in 'AE.IDE\AE.IDE.Versions.Consts.pas', 62 | AE.VirtualKeyboard.HuHu in 'AE.VirtualKeyboard\AE.VirtualKeyboard.HuHu.pas', 63 | AE.VirtualKeyboard in 'AE.VirtualKeyboard\AE.VirtualKeyboard.pas', 64 | AE.VirtualKeyboard.EnUs in 'AE.VirtualKeyboard\AE.VirtualKeyboard.EnUs.pas', 65 | AE.VirtualKeyboard.Foreign in 'AE.VirtualKeyboard\AE.VirtualKeyboard.Foreign.pas', 66 | AE.Comp.KeepMeAwake in 'AE.Comp\AE.Comp.KeepMeAwake.pas', 67 | AE.Comp.TagEditor in 'AE.Comp\AE.Comp.TagEditor.pas'; 68 | 69 | end. 70 | -------------------------------------------------------------------------------- /AE.Misc/AE.DLL.Loader.pas: -------------------------------------------------------------------------------- 1 | Unit AE.DLL.Loader; 2 | 3 | Interface 4 | 5 | Uses Generics.Collections; 6 | 7 | Type 8 | TAEDLLLoader = Class 9 | strict private 10 | _dllname: String; 11 | _dllhandle: THandle; 12 | _methods: TDictionary; 13 | Function GetMethod(Const inMethodName: String): Pointer; 14 | Function GetMethods: TArray; 15 | strict protected 16 | Procedure LoadMethods; Virtual; 17 | Function LoadMethod(Const inMethodName: String): Boolean; 18 | Function RaiseExceptionIfUnloadFails: Boolean; Virtual; 19 | Property DLLHandle: THandle Read _dllhandle; 20 | Property DLLName: String Read _dllname; 21 | public 22 | Constructor Create(Const inDLLName: String); ReIntroduce; Virtual; 23 | Destructor Destroy; Override; 24 | Property Method[Const inMethodName: String]: Pointer Read GetMethod; Default; 25 | Property Methods: TArray Read GetMethods; 26 | End; 27 | 28 | Implementation 29 | 30 | Uses WinApi.Windows, System.SysUtils; 31 | 32 | Constructor TAEDLLLoader.Create(Const inDLLName: String); 33 | Begin 34 | inherited Create; 35 | 36 | _methods := TDictionary.Create; 37 | _dllname := inDLLName; 38 | _dllhandle := 0; 39 | 40 | _dllhandle := LoadLibrary(PChar(_dllname)); 41 | 42 | If _dllhandle = 0 Then 43 | RaiseLastOSError; 44 | 45 | Self.LoadMethods; 46 | End; 47 | 48 | Destructor TAEDLLLoader.Destroy; 49 | Begin 50 | If _dllhandle <> 0 Then 51 | Begin 52 | If Not FreeLibrary(_dllhandle) And Self.RaiseExceptionIfUnloadFails Then 53 | RaiseLastOSError; 54 | 55 | _dllhandle := 0; 56 | End; 57 | 58 | FreeAndNil(_methods); 59 | 60 | inherited; 61 | End; 62 | 63 | Function TAEDLLLoader.GetMethod(Const inMethodName: String): Pointer; 64 | Begin 65 | _methods.TryGetValue(inMethodName, Result); 66 | End; 67 | 68 | Function TAEDLLLoader.GetMethods: TArray; 69 | Begin 70 | Result := _methods.Keys.ToArray; 71 | 72 | TArray.Sort(Result); 73 | End; 74 | 75 | Function TAEDLLLoader.LoadMethod(Const inMethodName: String): Boolean; 76 | Var 77 | tmp: Pointer; 78 | Begin 79 | tmp := getProcAddress(_dllhandle, PChar(inMethodName)); 80 | 81 | If Assigned(tmp) Then 82 | Begin 83 | Result := True; 84 | 85 | _methods.Add(inMethodName, tmp); 86 | End 87 | Else 88 | Result := False; 89 | End; 90 | 91 | Procedure TAEDLLLoader.LoadMethods; 92 | Begin 93 | _methods.Clear; 94 | End; 95 | 96 | Function TAEDLLLoader.RaiseExceptionIfUnloadFails: Boolean; 97 | Begin 98 | Result := True; 99 | End; 100 | 101 | End. 102 | -------------------------------------------------------------------------------- /AE.VirtualKeyboard/AE.VirtualKeyboard.Foreign.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.VirtualKeyboard.Foreign; 10 | 11 | Interface 12 | 13 | Uses AE.VirtualKeyboard, WinApi.Windows; 14 | 15 | Type 16 | TAEVirtualKeyboardButtonAction = ( vkbPress, vkbRelease); 17 | 18 | TAEVirtualForeignKeyboard = Class(TAEVirtualKeyboard) 19 | strict private 20 | _klayout: HKL; 21 | strict protected 22 | Procedure InternalTypeText(Const inText: String; Const inDelayInMs: Word); Override; 23 | Function InternalTranslateForeignKey(Const inKey: Char): TInputs; Virtual; Abstract; 24 | Function InternalTranslateKey(Const inKey: Char): TInputs; Override; 25 | Function KeyInput(Const inKey: Word; Const inAction: TAEVirtualKeyboardButtonAction): TInput; 26 | public 27 | Constructor Create; ReIntroduce; 28 | End; 29 | 30 | Implementation 31 | 32 | Uses System.SysUtils; 33 | 34 | Const 35 | KLF_SETFORPROCESS = $00000100; // https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-loadkeyboardlayouta 36 | 37 | Constructor TAEVirtualForeignKeyboard.Create; 38 | Begin 39 | inherited; 40 | 41 | _klayout := 0; 42 | End; 43 | 44 | Function TAEVirtualForeignKeyboard.InternalTranslateKey(Const inKey: Char): TInputs; 45 | Begin 46 | Result := Self.InternalTranslateForeignKey(inKey); 47 | End; 48 | 49 | Procedure TAEVirtualForeignKeyboard.InternalTypeText(Const inText: String; Const inDelayInMs: Word); 50 | Begin 51 | {$REGION 'Attempt to load the keyboard layout specified by the class'} 52 | _klayout := LoadKeyboardLayout(IntToHex(Self.LanguageID, 8), KLF_ACTIVATE Or KLF_SETFORPROCESS); 53 | 54 | If _klayout = 0 Then 55 | RaiseLastOSError; 56 | {$ENDREGION} 57 | 58 | Try 59 | inherited; 60 | Finally 61 | {$REGION 'Unload the keyboard layout'} 62 | If Not UnloadKeyboardLayout(_klayout) Then 63 | RaiseLastOSError; 64 | {$ENDREGION} 65 | End; 66 | End; 67 | 68 | Function TAEVirtualForeignKeyboard.KeyInput(Const inKey: Word; Const inAction: TAEVirtualKeyboardButtonAction): TInput; 69 | Begin 70 | ZeroMemory(@Result, SizeOf(Result)); 71 | 72 | Result.Itype := INPUT_KEYBOARD; 73 | Result.ki.wVk := inKey; 74 | Result.ki.wScan := MapVirtualKeyEx(Result.ki.wVk, 0, _klayout); 75 | 76 | Case InAction Of 77 | vkbPress: 78 | Result.ki.dwFlags := 0; 79 | vkbRelease: 80 | Result.ki.dwFlags := KEYEVENTF_KEYUP; 81 | End; 82 | End; 83 | 84 | End. 85 | -------------------------------------------------------------------------------- /AE.Comp/AE.Comp.HeaderMenuItem.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.HeaderMenuItem; 10 | 11 | Interface 12 | 13 | Uses Vcl.Menus, Vcl.Graphics, WinApi.Windows, System.Classes; 14 | 15 | Type 16 | TAEHeaderMenuItem = Class(TMenuItem) 17 | strict private 18 | Procedure SetEnabled(Const inEnabled: Boolean); 19 | Function GetEnabled: Boolean; 20 | protected 21 | Procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; 22 | State: TOwnerDrawState; TopLevel: Boolean); Override; 23 | Procedure DoAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; 24 | ARect: TRect; State: TOwnerDrawState); 25 | procedure DrawItem(ACanvas: TCanvas; ARect: TRect; 26 | Selected: Boolean); Override; 27 | Procedure Loaded; Override; 28 | Public 29 | Constructor Create(AOwner: TComponent); Override; 30 | published 31 | Property Enabled: Boolean Read GetEnabled Write SetEnabled; 32 | End; 33 | 34 | Implementation 35 | 36 | Uses Vcl.Themes, System.SysUtils; 37 | 38 | Procedure TAEHeaderMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; 39 | State: TOwnerDrawState; TopLevel: Boolean); 40 | Begin 41 | DoAdvancedDrawItem(Self, ACanvas, ARect, State); 42 | End; 43 | 44 | Constructor TAEHeaderMenuItem.Create(AOwner: TComponent); 45 | Begin 46 | inherited; 47 | 48 | Self.Enabled := False; 49 | OnAdvancedDrawItem := DoAdvancedDrawItem; 50 | End; 51 | 52 | Procedure TAEHeaderMenuItem.DoAdvancedDrawItem(Sender: TObject; 53 | ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState); 54 | Begin 55 | ACanvas.Brush.Color := TStyleManager.ActiveStyle.GetStyleColor 56 | (scPanelDisabled); 57 | ACanvas.FillRect(ARect); 58 | ACanvas.Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor 59 | (sfWindowTextNormal); 60 | ACanvas.Font.Style := [fsBold]; 61 | ACanvas.TextRect(ARect, ARect.Left + 3, ARect.Top + 3, StripHotkey(Caption)); 62 | End; 63 | 64 | procedure TAEHeaderMenuItem.DrawItem(ACanvas: TCanvas; ARect: TRect; 65 | Selected: Boolean); 66 | begin 67 | inherited; 68 | // 69 | end; 70 | 71 | Function TAEHeaderMenuItem.GetEnabled: Boolean; 72 | Begin 73 | Result := inherited Enabled; 74 | End; 75 | 76 | Procedure TAEHeaderMenuItem.Loaded; 77 | Begin 78 | inherited; 79 | 80 | Self.Enabled := False; 81 | End; 82 | 83 | Procedure TAEHeaderMenuItem.SetEnabled(Const inEnabled: Boolean); 84 | Begin 85 | inherited Enabled := False; 86 | End; 87 | 88 | End. 89 | -------------------------------------------------------------------------------- /AE.Misc/AE.DLL.AutoLoader.pas: -------------------------------------------------------------------------------- 1 | Unit AE.DLL.AutoLoader; 2 | 3 | Interface 4 | 5 | Uses AE.DLL.Loader; 6 | 7 | Type 8 | TAEDLLAutoLoader = Class(TAEDLLLoader) 9 | strict protected 10 | Procedure LoadMethods; Override; 11 | End; 12 | 13 | Implementation 14 | 15 | Uses WinApi.Windows, System.SysUtils; 16 | 17 | Type 18 | PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS; 19 | PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY; 20 | 21 | Function ImageNtHeader(Base: Pointer): PIMAGE_NT_HEADERS; StdCall; External 'dbghelp.dll'; 22 | Function ImageRvaToVa(NtHeaders: Pointer; Base: Pointer; Rva: ULONG; LastRvaSection: Pointer): Pointer; StdCall; External 'dbghelp.dll'; 23 | 24 | Procedure TAEDLLAutoLoader.LoadMethods; 25 | Var 26 | a: Integer; 27 | filehandle, imagehandle: THandle; 28 | imageptr: Pointer; 29 | header: PIMAGE_NT_HEADERS; 30 | exporttable: PIMAGE_EXPORT_DIRECTORY; 31 | namesptr: PCardinal; 32 | nameptr: PAnsiChar; 33 | Begin 34 | inherited; 35 | 36 | // https://stackoverflow.com/questions/31917322/how-to-get-all-the-exported-functions-in-a-dll 37 | 38 | filehandle := CreateFile(PChar(Self.DLLName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); 39 | 40 | If filehandle = INVALID_HANDLE_VALUE Then 41 | RaiseLastOSError; 42 | 43 | Try 44 | imagehandle := CreateFileMapping(filehandle, nil, PAGE_READONLY, 0, 0, nil); 45 | 46 | If imagehandle = 0 Then 47 | RaiseLastOSError; 48 | 49 | Try 50 | imageptr := MapViewOfFile(imagehandle, FILE_MAP_READ, 0, 0, 0); 51 | 52 | If Not Assigned(imageptr) Then 53 | RaiseLastOSError; 54 | 55 | Try 56 | header := ImageNtHeader(imageptr); 57 | 58 | If Not Assigned(header) Then 59 | RaiseLastOSError; 60 | 61 | If header.Signature <> $00004550 Then // "PE\0\0" as a DWORD. 62 | Raise EOSError.Create('Incorrect image NT header signature!'); 63 | 64 | exporttable := ImageRvaToVa(header, imageptr, header.OptionalHeader.DataDirectory[0].VirtualAddress, nil); 65 | 66 | If Not Assigned(exporttable) Then 67 | RaiseLastOSError; 68 | 69 | namesptr := ImageRvaToVa(header, imageptr, Cardinal(exporttable.AddressOfNames), nil); 70 | 71 | If Not Assigned(namesptr) Then 72 | RaiseLastOSError; 73 | 74 | For a := 0 To exporttable.NumberOfNames-1 Do 75 | Begin 76 | nameptr := ImageRvaToVa(header, imageptr, namesptr^, nil); 77 | 78 | If Not Assigned(nameptr) Then 79 | RaiseLastOSError; 80 | 81 | Self.LoadMethod(String(nameptr)); 82 | 83 | Inc(namesptr); 84 | End; 85 | Finally 86 | UnmapViewOfFile(imageptr); 87 | End; 88 | Finally 89 | CloseHandle(imagehandle); 90 | End; 91 | Finally 92 | CloseHandle(filehandle); 93 | End; 94 | End; 95 | 96 | End. 97 | -------------------------------------------------------------------------------- /AE.Comp/AE.Comp.MenuTreeParser.pas: -------------------------------------------------------------------------------- 1 | Unit AE.Comp.MenuTreeParser; 2 | 3 | Interface 4 | 5 | Uses System.Classes; 6 | 7 | Type 8 | TAEMenuTreeParser = Class(TComponent) 9 | strict private 10 | _allmenuitems: TStringList; 11 | _location: String; 12 | _locationfolders: TArray; 13 | _locationmenuitems: TArray; 14 | _separator: Char; 15 | Procedure AllMenuItemsChanged(Sender: TObject); 16 | Procedure SetAllMenuItems(Const inMenuItems: TStringList); 17 | Procedure SetLocation(inLocation: String); 18 | public 19 | Constructor Create(AOwner: TComponent); Override; 20 | Destructor Destroy; Override; 21 | published 22 | Property Location: String Read _location Write SetLocation; 23 | Property LocationFolders: TArray Read _locationfolders; 24 | Property LocationMenuItems: TArray Read _locationmenuitems; 25 | Property AllMenuItems: TStringList Read _allmenuitems Write SetAllMenuItems; 26 | Property SeparatorChar: Char Read _separator Write _separator; 27 | End; 28 | 29 | Implementation 30 | 31 | Uses System.SysUtils, System.Generics.Collections; 32 | 33 | Procedure TAEMenuTreeParser.AllMenuItemsChanged(Sender: TObject); 34 | Begin 35 | Self.Location := ''; 36 | End; 37 | 38 | Constructor TAEMenuTreeParser.Create(AOwner: TComponent); 39 | Begin 40 | inherited; 41 | 42 | _allmenuitems := TStringList.Create; 43 | _allmenuitems.OnChange := AllMenuItemsChanged; 44 | 45 | _separator := '\'; 46 | 47 | Self.Location := ''; 48 | End; 49 | 50 | Destructor TAEMenuTreeParser.Destroy; 51 | Begin 52 | FreeAndNil(_allmenuitems); 53 | 54 | inherited; 55 | End; 56 | 57 | Procedure TAEMenuTreeParser.SetAllMenuItems(Const inMenuItems: TStringList); 58 | Begin 59 | _allmenuitems.Assign(inMenuItems); 60 | End; 61 | 62 | Procedure TAEMenuTreeParser.SetLocation(inLocation: String); 63 | Var 64 | a: NativeInt; 65 | itemname: String; 66 | folders: TList; 67 | Begin 68 | _location := inLocation; 69 | 70 | If Not inLocation.IsEmpty And Not inLocation.EndsWith(_separator) Then 71 | inLocation := inLocation + _separator; 72 | 73 | SetLength(_locationfolders, 0); 74 | SetLength(_locationmenuitems, 0); 75 | 76 | folders := TList.Create; 77 | Try 78 | For a := 0 To _allmenuitems.Count - 1 Do 79 | If _allmenuitems[a].StartsWith(inLocation) Then 80 | Begin 81 | itemname := _allmenuitems[a].Substring(inLocation.Length); 82 | 83 | If itemname.Contains(_separator) Then 84 | Begin 85 | itemname := itemname.Substring(0, itemname.IndexOf(_separator)); 86 | 87 | If Not folders.Contains(itemname) Then 88 | folders.Add(itemname); 89 | End 90 | Else 91 | Begin 92 | SetLength(_locationmenuitems, Length(_locationmenuitems) + 1); 93 | 94 | _locationmenuitems[High(_locationmenuitems)] := itemname; 95 | End; 96 | End; 97 | 98 | _locationfolders := folders.ToArray; 99 | 100 | TArray.Sort(_locationfolders); 101 | TArray.Sort(_locationmenuitems); 102 | Finally 103 | FreeAndNil(folders); 104 | End; 105 | End; 106 | 107 | End. 108 | -------------------------------------------------------------------------------- /AE.Updater/AE.Comp.Updater.FileProvider.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.Updater.FileProvider; 10 | 11 | Interface 12 | 13 | Uses System.Classes, System.SysUtils; 14 | 15 | Type 16 | EAEUpdaterFileProviderException = Class(Exception) 17 | strict private 18 | _filename: String; 19 | public 20 | Constructor Create(Const inMessage: String; Const inFileName: String = ''); ReIntroduce; Virtual; 21 | Property URL: String Read _filename; 22 | End; 23 | 24 | TAEUpdaterFileProviderOnFileRequestedEvent = Procedure(Sender: TObject; Const inFileName: String) Of Object; 25 | 26 | TAEUpdaterFileProviderOnFileProvided = Procedure(Sender: TObject; Const inFileName: String; Const outStream: TStream) Of Object; 27 | 28 | TAEUpdaterFileProvider = Class(TComponent) 29 | strict private 30 | _onfileprovided: TAEUpdaterFileProviderOnFileProvided; 31 | _onfilerequested: TAEUpdaterFileProviderOnFileRequestedEvent; 32 | _updatefilename: String; 33 | strict protected 34 | Procedure InternalProvideFile(Const inURL: String; Const outStream: TStream); Virtual; Abstract; 35 | Procedure InternalResetCache; Virtual; 36 | Function InternalUpdateRoot: String; Virtual; Abstract; 37 | public 38 | Constructor Create(AOwner: TComponent); Override; 39 | Procedure ProvideFile(Const inFileName: String; Const outStream: TStream); 40 | Procedure ProvideUpdateFile(Const outStream: TStream); 41 | Procedure ResetCache; 42 | Function UpdateRoot: String; 43 | published 44 | Property OnFileProvided: TAEUpdaterFileProviderOnFileProvided Read _onfileprovided Write _onfileprovided; 45 | Property OnFileRequested: TAEUpdaterFileProviderOnFileRequestedEvent Read _onfilerequested Write _onfilerequested; 46 | Property UpdateFileName: String Read _updatefilename Write _updatefilename; 47 | End; 48 | 49 | Implementation 50 | 51 | // 52 | // EAEUpdaterFileProviderException 53 | // 54 | 55 | Constructor EAEUpdaterFileProviderException.Create(Const inMessage, inFileName: String); 56 | Begin 57 | inherited Create(inMessage); 58 | 59 | _filename := inFileName; 60 | End; 61 | 62 | // 63 | // TAEUpdaterFileProvider 64 | // 65 | 66 | Constructor TAEUpdaterFileProvider.Create(AOwner: TComponent); 67 | Begin 68 | inherited; 69 | 70 | _onfileprovided := nil; 71 | _onfilerequested := nil; 72 | _updatefilename := ''; 73 | End; 74 | 75 | Procedure TAEUpdaterFileProvider.InternalResetCache; 76 | Begin 77 | // Dummy 78 | End; 79 | 80 | Procedure TAEUpdaterFileProvider.ProvideFile(Const inFileName: String; Const outStream: TStream); 81 | Begin 82 | If Assigned(_onfilerequested) Then 83 | _onfilerequested(Self, inFileName); 84 | 85 | Self.InternalProvideFile(inFileName, outStream); 86 | 87 | If Assigned(_onfileprovided) Then 88 | _onfileprovided(Self, inFileName, outStream); 89 | End; 90 | 91 | Procedure TAEUpdaterFileProvider.ProvideUpdateFile(Const outStream: TStream); 92 | Begin 93 | If _updatefilename.IsEmpty Then 94 | Raise EAEUpdaterFileProviderException.Create('Update file is not defined!'); 95 | 96 | Self.ProvideFile(Self.UpdateFileName, outStream); 97 | End; 98 | 99 | Procedure TAEUpdaterFileProvider.ResetCache; 100 | Begin 101 | Self.InternalResetCache; 102 | End; 103 | 104 | Function TAEUpdaterFileProvider.UpdateRoot: String; 105 | Begin 106 | Result := Self.InternalUpdateRoot; 107 | End; 108 | 109 | End. 110 | -------------------------------------------------------------------------------- /AE.VirtualKeyboard/AE.VirtualKeyboard.EnUs.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.VirtualKeyboard.EnUs; 10 | 11 | Interface 12 | 13 | Uses AE.VirtualKeyboard.Foreign, AE.VirtualKeyboard; 14 | 15 | Type 16 | TAEVirtualEnUsKeyboard = Class(TAEVirtualForeignKeyboard) 17 | strict protected 18 | Class Function LanguageID: Cardinal; Override; 19 | Function InternalTranslateForeignKey(Const inKey: Char): TInputs; Override; 20 | End; 21 | 22 | Implementation 23 | 24 | Function TAEVirtualEnUsKeyboard.InternalTranslateForeignKey(Const inKey: Char): TInputs; 25 | Var 26 | shift: Boolean; 27 | code: Word; 28 | kpos: Integer; 29 | Begin 30 | SetLength(Result, 0); 31 | 32 | shift := False; 33 | code := Ord(inKey); 34 | 35 | {$REGION 'Change key code and shift state for specific keys'} 36 | Case inKey Of 37 | '!': 38 | Begin 39 | shift := True; 40 | code := 49; 41 | End; 42 | '"': 43 | Begin 44 | shift := True; 45 | code := 222; 46 | End; 47 | '#': 48 | Begin 49 | shift := True; 50 | code := 51; 51 | End; 52 | '$': 53 | Begin 54 | shift := True; 55 | code := 52; 56 | End; 57 | '%': 58 | Begin 59 | shift := True; 60 | code := 53; 61 | End; 62 | '&': 63 | Begin 64 | shift := True; 65 | code := 55; 66 | End; 67 | '''': 68 | code := 222; 69 | '(': 70 | Begin 71 | shift := True; 72 | code := 57; 73 | End; 74 | ')': 75 | Begin 76 | shift := True; 77 | code := 48; 78 | End; 79 | '*': 80 | Begin 81 | shift := True; 82 | code := 56; 83 | End; 84 | '+': 85 | Begin 86 | shift := True; 87 | code := 187; 88 | End; 89 | ',': 90 | code := 188; 91 | '-': 92 | code := 189; 93 | '.': 94 | code := 190; 95 | '/': 96 | code := 191; 97 | ':': 98 | Begin 99 | shift := True; 100 | code := 186; 101 | End; 102 | ';': 103 | code := 186; 104 | '<': 105 | Begin 106 | shift := True; 107 | code := 188; 108 | End; 109 | '=': 110 | code := 187; 111 | '>': 112 | Begin 113 | shift := True; 114 | code := 190; 115 | End; 116 | '?': 117 | Begin 118 | shift := True; 119 | code := 191; 120 | End; 121 | '@': 122 | Begin 123 | shift := True; 124 | code := 50; 125 | End; 126 | 'A'..'Z': 127 | shift := True; 128 | '[': 129 | code := 219; 130 | '\': 131 | code := 220; 132 | ']': 133 | code := 221; 134 | '^': 135 | Begin 136 | shift := True; 137 | code := 54; 138 | End; 139 | '_': 140 | Begin 141 | shift := True; 142 | code := 189; 143 | End; 144 | '`': 145 | code := 192; 146 | 'a'..'z': 147 | code := code - 32; 148 | '{': 149 | Begin 150 | shift := True; 151 | code := 219; 152 | End; 153 | '|': 154 | Begin 155 | shift := True; 156 | code := 220 157 | End; 158 | '}': 159 | Begin 160 | shift := True; 161 | code := 221; 162 | End; 163 | '~': 164 | Begin 165 | shift := True; 166 | code := 49; 167 | End; 168 | End; 169 | {$ENDREGION} 170 | 171 | If shift Then 172 | Begin 173 | SetLength(Result, 4); 174 | 175 | kpos := 1; 176 | 177 | Result[0] := KeyInput(16, vkbPress); // Press Shift 178 | Result[3] := KeyInput(16, vkbRelease); // Release Shift 179 | End 180 | Else 181 | Begin 182 | SetLength(Result, 2); 183 | 184 | kpos := 0; 185 | End; 186 | 187 | Result[kpos] := KeyInput(code, vkbPress); 188 | Result[kpos + 1] := KeyInput(code, vkbRelease); 189 | End; 190 | 191 | Class Function TAEVirtualEnUsKeyboard.LanguageID: Cardinal; 192 | Begin 193 | Result := 1033; 194 | End; 195 | 196 | Initialization 197 | RegisterKeyboard(TAEVirtualEnUsKeyboard); 198 | 199 | End. 200 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # AEFramework 2 | 3 | AEFramework is a set of helper units / components which I use for most of my projects. Since they might be of interest of others it is now hosted on GitHub. Feel free to use, modify under [Creative Commons Attribution 4.0 International](http://creativecommons.org/licenses/by/4.0/) 4 | 5 | ## AE.Application 6 | These classes can be used to quickly create a service / console application. 7 | 8 | ## AE.Comp 9 | Fixes and enhancements for existing VCL controls. These controls fully support Delphi VCL styles. 10 | 11 | #### AE.Comp.ComboBox.pas 12 | Contains TAEComboBox, which allows case-insensitive item selection while typing if Style is csDropDown. 13 | 14 | #### AE.Comp.DBGrid.pas 15 | Contains TAEDBGrid with automatic column width detection, proper mouse wheel and scrollbar scrolling, scrollbar positioning, alternate row backgrounds and some painting improvements. 16 | 17 | #### AE.Comp.HeaderMenuItem.pas 18 | TAEHeaderMenuItem is always disabled, acts as a separator in Popup / main menus. Born because of a topic on [DelphiPraxis](https://en.delphipraxis.net/topic/5397-tpopupmenu-with-group-headers). 19 | 20 | #### AE.Comp.KeepMeAwake.pas 21 | TAEKeepMeAwake can be used to prevent a computers console or RDP session to go idle. 22 | 23 | #### AE.Comp.MenuTreeParser.pas 24 | TAEMenuTreeParser is a helper component to parse menu trees. Based on the current location it can list subfolders and menu items separately. 25 | 26 | #### AE.Comp.PageControl.pas 27 | TAEPageControl adds drag-and-drop sheet reordering and close buttons on tabs. 28 | 29 | #### AE.Comp.TagEditor.pas 30 | TAETagEditor is an extremely barebone tag editor component. More information on [DelphiPraxis](https://en.delphipraxis.net/topic/14451-very-simple-tag-editor-component). 31 | 32 | #### AE.Comp.ThreadedTimer.pas 33 | TAEThreadedTimer is a modernized, drop-in replacement of Delphi's TTimer class based on a [StackExchange](https://codereview.stackexchange.com/questions/153819/ttimerthread-threaded-timer-class) StackExchange. More information is on [DelphiPraxis](https://en.delphipraxis.net/topic/6621-tthreadedtimer). 34 | 35 | ## AE.IDE 36 | TAEDelphiVersions and TVSVersions detect local Delphi and Visual Studio installations and their individual running instances. Via DDE a file can be opened in the IDE of a specific instance. You can read the struggle of creation on [DelphiPraxis](https://en.delphipraxis.net/topic/7955-how-to-open-a-file-in-the-already-running-ide). 37 | 38 | ## AE.Misc 39 | Miscellaneous unit to make life easier. 40 | 41 | #### AE.DDEManager.pas 42 | As Delphi's TDDEClientConv is severely out-of-date and is not fully functional on newer releases, TAEDDEManager can take care of DDE server discovery and command execution. 43 | 44 | #### AE.DLL.Loader.pas, AE.DLL.AutoLoader.pas 45 | Helper classes to make interacting with DLL files less painful. TAEDLLLoader requires the descendant class to loading manually while TAEDLLAutoLoader discovers and loads all exported methods. 46 | 47 | #### AE.Helper.TBytes.pas 48 | Helper class to compare, fully clear and deallocate, via ZLib (de)compress, stringify and manipulate Delphi TBytes arrays. 49 | 50 | #### AE.Misc.FileUtils.pas 51 | Extracts specific version information from a given executable, like version number, product name, etc. 52 | 53 | #### AE.Misc.Random.pas 54 | TAERandom is a pure pascal pseudorandom generator which can have multiple individual instances with different seeds. Currently two useable version exists, TAEDelphiRandom and TAEXORShift. 55 | 56 | #### AE.Misc.UnixTimestamp.pas 57 | Before I realized Delphi now natively supports UTC converted Unix timestamps I used this unit to do those conversions. Now it only calls the Delphi methods. 58 | 59 | #### MNB.ExchangeRate.SoapService.pas and AE.MNB.ExchangeRates.pas 60 | Access the webservice of Hungarian National Bank, get exchange rates and convert between currency values. The first file is the WSDL import of the webservice of [Hungarian National Bank](https://www.mnb.hu/sajtoszoba/sajtokozlemenyek/2015-evi-sajtokozlemenyek/tajekoztatas-az-arfolyam-webservice-mukodeserol), the second one is an installable component which makes it easy to convert between the [supported](https://mnb.hu/arfolyamok) currencies. 61 | 62 | ## AE.Updater 63 | TAEUpdater is a free to use application autoupdater. More information on [DelphiPraxis](https://en.delphipraxis.net/topic/7711-free-low-maintenance-update-mechanism). 64 | 65 | ## AE.VirtualKeyboard.*.pas 66 | A wrapper class to allow foreground or background threads to send key inputs to the active application, like actual keys were pressed on a keyboard. TAEVirtualKeyboard uses the actual keyboard layout and sends the text as unicode, while TAEVirtualEnUsKeyboard and TAEVirtualHuHuKeyboard translates special characters and sends the input as scan codes instead. These can be useful to type text to a RDP window, if the host system has no keyboard layout matching the clients. 67 | -------------------------------------------------------------------------------- /AE.Updater/AE.Comp.Updater.FileProvider.HTTP.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.Updater.FileProvider.HTTP; 10 | 11 | Interface 12 | 13 | Uses AE.Comp.Updater.FileProvider, System.Net.HttpClientComponent, System.Generics.Collections, System.Classes; 14 | 15 | Type 16 | EAEUpdaterHTTPFileProviderException = Class(EAEUpdaterFileProviderException) 17 | strict private 18 | _statuscode: Integer; 19 | _statustext: String; 20 | public 21 | Constructor Create(Const inMessage: String; Const inURL: String = ''; Const inStatusCode: Integer = -1; Const inStatusText: String = ''); ReIntroduce; 22 | Property StatusCode: Integer Read _statuscode; 23 | Property StatusText: String Read _statustext; 24 | End; 25 | 26 | TAEUpdaterHTTPFileProvider = Class(TAEUpdaterFileProvider) 27 | strict private 28 | _etags: TDictionary; 29 | _httpclient: TNetHTTPClient; 30 | Procedure SetETag(Const inURL, inETag: String); 31 | Function GetETag(Const inURL: String): String; 32 | Function GetETags: TArray; 33 | strict protected 34 | Procedure InternalProvideFile(Const inFileName: String; Const outStream: TStream); Override; 35 | Procedure InternalResetCache; Override; 36 | Function InternalUpdateRoot: String; Override; 37 | public 38 | Constructor Create(AOwner: TComponent); Override; 39 | Destructor Destroy; Override; 40 | Property ETag[Const inURL: String]: String Read GetETag Write SetETag; 41 | Property ETags: TArray Read GetETags; 42 | Property HTTPClient: TNetHTTPClient Read _httpclient; 43 | End; 44 | 45 | Implementation 46 | 47 | Uses System.SysUtils, System.Net.URLClient, System.Net.HttpClient; 48 | 49 | // 50 | // EAEUpdaterException 51 | // 52 | 53 | Constructor EAEUpdaterHTTPFileProviderException.Create(Const inMessage: String; Const inURL: String = ''; Const inStatusCode: Integer = -1; Const inStatusText: String = ''); 54 | Begin 55 | inherited Create(inMessage, inURL); 56 | 57 | _statustext := inStatusText; 58 | _statuscode := inStatusCode; 59 | End; 60 | 61 | // 62 | // TAEUpdaterHTTPFileProvider 63 | // 64 | 65 | Constructor TAEUpdaterHTTPFileProvider.Create(AOwner: TComponent); 66 | Begin 67 | inherited; 68 | 69 | _etags := TDictionary.Create; 70 | _httpclient := TNetHTTPClient.Create(Self); 71 | End; 72 | 73 | Destructor TAEUpdaterHTTPFileProvider.Destroy; 74 | Begin 75 | FreeAndNil(_etags); 76 | 77 | inherited; 78 | End; 79 | 80 | Function TAEUpdaterHTTPFileProvider.GetETag(Const inURL: String): String; 81 | Begin 82 | _etags.TryGetValue(inURL, Result); 83 | End; 84 | 85 | Function TAEUpdaterHTTPFileProvider.GetETags: TArray; 86 | Begin 87 | Result := _etags.Keys.ToArray; 88 | End; 89 | 90 | Procedure TAEUpdaterHTTPFileProvider.InternalProvideFile(Const inFileName: String; Const outStream: TStream); 91 | Var 92 | headers: TArray; 93 | hr: IHTTPResponse; 94 | Begin 95 | If Not _etags.ContainsKey(inFileName) Then 96 | SetLength(headers, 0) 97 | Else 98 | Begin 99 | SetLength(headers, 1); 100 | headers[0].Name := 'If-None-Match'; 101 | headers[0].Value := _etags[inFileName]; 102 | End; 103 | 104 | hr := _httpclient.Get(inFileName, nil, headers); 105 | 106 | If Not Assigned(hr) Then 107 | Raise EAEUpdaterHTTPFileProviderException.Create('Downloading the requested file failed, web server could not be reached!', inFileName); 108 | 109 | If hr.StatusCode = 304 Then // 304 was provided because of ETag = no updates are available 110 | Exit 111 | Else 112 | If hr.StatusCode <> 200 Then 113 | Raise EAEUpdaterHTTPFileProviderException.Create('Requested file could not be downloaded!', inFileName, hr.StatusCode, hr.StatusText); 114 | 115 | outStream.CopyFrom(hr.ContentStream, hr.ContentStream.Size); 116 | 117 | If hr.ContainsHeader('ETag') Then 118 | Self.ETag[inFileName] := hr.HeaderValue['ETag']; 119 | End; 120 | 121 | Procedure TAEUpdaterHTTPFileProvider.InternalResetCache; 122 | Begin 123 | inherited; 124 | 125 | _etags.Clear; 126 | End; 127 | 128 | Function TAEUpdaterHTTPFileProvider.InternalUpdateRoot: String; 129 | Begin 130 | Result := Self.UpdateFileName.Substring(0, Self.UpdateFileName.LastIndexOf('/') + 1); 131 | End; 132 | 133 | Procedure TAEUpdaterHTTPFileProvider.SetETag(Const inURL, inETag: String); 134 | Begin 135 | If Not inETag.IsEmpty Then 136 | _etags.AddOrSetValue(inURL, inETag) 137 | Else 138 | _etags.Remove(inURL); 139 | End; 140 | 141 | End. 142 | -------------------------------------------------------------------------------- /AE.Misc/AE.Misc.Random.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Misc.Random; 10 | 11 | Interface 12 | 13 | Type 14 | TAERandomSeed = Array Of Integer; 15 | 16 | TAERandom = Class 17 | strict private 18 | Procedure SetSeed(inSeed: TAERandomSeed); 19 | Function GetSeed: TAERandomSeed; 20 | strict protected 21 | Procedure InternalRandomSeed; Virtual; Abstract; 22 | Procedure InternalSetSeed(inSeed: TAERandomSeed); Virtual; Abstract; 23 | Function InternalGetSeed: TAERandomSeed; Virtual; Abstract; 24 | Function InternalNext: Integer; Virtual; Abstract; 25 | public 26 | Constructor Create; ReIntroduce; 27 | Procedure RandomSeed; 28 | Function Next: Integer; Overload; 29 | Function Next(inUpperRange: Integer): Integer; Overload; 30 | Property Seed: TAERandomSeed Read GetSeed Write SetSeed; 31 | End; 32 | 33 | TAEDelphiRandom = Class(TAERandom) 34 | strict private 35 | _seed: Integer; 36 | strict protected 37 | Procedure InternalRandomSeed; Override; 38 | Procedure InternalSetSeed(inSeed: TAERandomSeed); Override; 39 | Function InternalGetSeed: TAERandomSeed; Override; 40 | Function InternalNext: Integer; Override; 41 | End; 42 | 43 | TAEXORShift = Class(TAERandom) 44 | Type 45 | TXORShiftSeed = Record 46 | p0, p1, p2, p3: Cardinal; 47 | End; 48 | strict private 49 | _seed: TXORShiftSeed; 50 | strict protected 51 | Procedure InternalRandomSeed; Override; 52 | Procedure InternalSetSeed(inSeed: TAERandomSeed); Override; 53 | Function InternalGetSeed: TAERandomSeed; Override; 54 | Function InternalNext: Integer; Override; 55 | End; 56 | 57 | Implementation 58 | 59 | Uses System.SysUtils, System.Math; 60 | 61 | {$R-} 62 | 63 | Var 64 | _randomized: Boolean; 65 | 66 | // 67 | // Internal, helper functions 68 | // 69 | 70 | Function SysRndInt: Integer; 71 | Begin 72 | Result := RandomRange(Integer.MinValue, Integer.MaxValue); 73 | End; 74 | 75 | // 76 | // TAESHMRandom 77 | // 78 | 79 | Constructor TAERandom.Create; 80 | Begin 81 | inherited; 82 | Self.RandomSeed; 83 | End; 84 | 85 | Function TAERandom.GetSeed: TAERandomSeed; 86 | Begin 87 | Result := InternalGetSeed; 88 | End; 89 | 90 | Function TAERandom.Next(inUpperRange: Integer): Integer; 91 | Var 92 | tmp: UInt32; 93 | Begin 94 | tmp := Self.Next; 95 | Result := (UInt64(UInt32(inUpperRange)) * UInt64(tmp)) Shr 32; 96 | End; 97 | 98 | Function TAERandom.Next: Integer; 99 | Begin 100 | Result := InternalNext; 101 | End; 102 | 103 | Procedure TAERandom.RandomSeed; 104 | Begin 105 | If Not _randomized Then 106 | Begin 107 | Randomize; 108 | _randomized := True; 109 | End; 110 | Self.InternalRandomSeed; 111 | End; 112 | 113 | Procedure TAERandom.SetSeed(inSeed: TAERandomSeed); 114 | Begin 115 | InternalSetSeed(inSeed); 116 | End; 117 | 118 | // 119 | // TDelphi 120 | // 121 | 122 | Function TAEDelphiRandom.InternalGetSeed: TAERandomSeed; 123 | Begin 124 | SetLength(Result, 1); 125 | Result[0] := _seed; 126 | End; 127 | 128 | Function TAEDelphiRandom.InternalNext: Integer; 129 | Begin 130 | _seed := Integer(_seed * $08088405) + 1; 131 | Result := _seed * Integer.MaxValue Shr 32; 132 | End; 133 | 134 | Procedure TAEDelphiRandom.InternalRandomSeed; 135 | Begin 136 | _seed := SysRndInt; 137 | End; 138 | 139 | Procedure TAEDelphiRandom.InternalSetSeed(inSeed: TAERandomSeed); 140 | Begin 141 | If Length(inSeed) > 0 Then 142 | _seed := inSeed[0] 143 | Else 144 | _seed := 0; 145 | End; 146 | 147 | // 148 | // TXORShift 149 | // 150 | 151 | Function TAEXORShift.InternalNext: Integer; 152 | Var 153 | t: UInt32; 154 | Begin 155 | t := _seed.p0 XOr (_seed.p0 Shl 11); 156 | _seed.p0 := _seed.p1; 157 | _seed.p1 := _seed.p2; 158 | _seed.p2 := _seed.p3; 159 | _seed.p3 := _seed.p3 XOr (_seed.p3 Shr 19) XOr (t XOr (t Shr 8)); 160 | Result := _seed.p3; 161 | End; 162 | 163 | Function TAEXORShift.InternalGetSeed: TAERandomSeed; 164 | Begin 165 | SetLength(Result, 4); 166 | Result[0] := _seed.p0; 167 | Result[1] := _seed.p1; 168 | Result[2] := _seed.p2; 169 | Result[3] := _seed.p3; 170 | End; 171 | 172 | Procedure TAEXORShift.InternalRandomSeed; 173 | Begin 174 | _seed.p0 := SysRndInt; 175 | _seed.p1 := SysRndInt; 176 | _seed.p2 := SysRndInt; 177 | _seed.p3 := SysRndInt; 178 | End; 179 | 180 | Procedure TAEXORShift.InternalSetSeed(inSeed: TAERandomSeed); 181 | Begin 182 | If Length(inSeed) > 0 Then 183 | _seed.p0 := inSeed[0] 184 | Else 185 | _seed.p0 := 0; 186 | If Length(inSeed) > 1 Then 187 | _seed.p1 := inSeed[1] 188 | Else 189 | _seed.p1 := 1; 190 | If Length(inSeed) > 2 Then 191 | _seed.p2 := inSeed[2] 192 | Else 193 | _seed.p2 := 2; 194 | If Length(inSeed) > 3 Then 195 | _seed.p3 := inSeed[3] 196 | Else 197 | _seed.p3 := 3; 198 | End; 199 | 200 | Initialization 201 | 202 | _randomized := False; 203 | 204 | End. 205 | -------------------------------------------------------------------------------- /AE.VirtualKeyboard/AE.VirtualKeyboard.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.VirtualKeyboard; 10 | 11 | Interface 12 | 13 | Uses WinApi.Windows; 14 | 15 | Type 16 | TInputs = TArray; 17 | 18 | TAEVirtualKeyboard = Class 19 | strict protected 20 | Class Function InternalGetKeyboardName: String; Virtual; 21 | Class Function LanguageID: Cardinal; Virtual; 22 | Procedure InternalTypeText(Const inText: String; Const inDelayInMs: Word); Virtual; 23 | Function InternalTranslateKey(Const inKey: Char): TInputs; Virtual; 24 | public 25 | Procedure TypeText(Const inText: String; inDelayInMs: Word = 10); 26 | Class Function KeyboardName: String; 27 | End; 28 | 29 | TAEVirtualKeyboardClass = Class Of TAEVirtualKeyboard; 30 | 31 | Procedure RegisterKeyboard(inKeyboardClass: TAEVirtualKeyboardClass); 32 | Function Keyboards: TArray; 33 | 34 | Implementation 35 | 36 | Uses System.SysUtils, System.Generics.Collections; 37 | 38 | Var 39 | _keyboards: TArray; 40 | 41 | // 42 | // Internal, helper functions 43 | // 44 | 45 | Procedure RegisterKeyboard(inKeyboardClass: TAEVirtualKeyboardClass); 46 | Begin 47 | SetLength(_keyboards, Length(_keyboards) + 1); 48 | _keyboards[High(_keyboards)] := inKeyboardClass; 49 | End; 50 | 51 | Function Keyboards: TArray; 52 | Begin 53 | Result := _keyboards; 54 | End; 55 | 56 | // 57 | // TAEVirtualKeyboard 58 | // 59 | 60 | Class Function TAEVirtualKeyboard.InternalGetKeyboardName: String; 61 | Var 62 | buf: Array[0..LOCALE_NAME_MAX_LENGTH - 1] Of WideChar; 63 | Begin 64 | If LCIDToLocaleName(Self.LanguageID, buf, LOCALE_NAME_MAX_LENGTH, 0) = 0 Then 65 | RaiseLastOSError; 66 | 67 | Result := 'AE virtual ' + buf + ' keyboard'; 68 | End; 69 | 70 | Function TAEVirtualKeyboard.InternalTranslateKey(Const inKey: Char): TInputs; 71 | Begin 72 | ZeroMemory(@Result, SizeOf(Result)); 73 | 74 | SetLength(Result, 2); 75 | 76 | Result[0].Itype := INPUT_KEYBOARD; 77 | Result[0].ki.wScan := Ord(inKey); 78 | Result[0].ki.dwFlags := KEYEVENTF_UNICODE; 79 | 80 | Result[1].Itype := INPUT_KEYBOARD; 81 | Result[1].ki.wScan := Ord(inKey); 82 | Result[1].ki.dwFlags := KEYEVENTF_UNICODE Or KEYEVENTF_KEYUP; 83 | End; 84 | 85 | Procedure TAEVirtualKeyboard.InternalTypeText(Const inText: String; Const inDelayInMs: Word); 86 | Var 87 | allinputs: TList; 88 | inputs: TInputs; 89 | c: Char; 90 | Begin 91 | If inDelayInMs > 0 Then 92 | {$REGION 'Type the text one by one, sleeping between each character press'} 93 | For c In inText Do 94 | Begin 95 | inputs := Self.InternalTranslateKey(c); 96 | 97 | If Length(inputs) > 0 Then 98 | Begin 99 | SendInput(Length(inputs), inputs[0], SizeOf(TInput)); 100 | 101 | Sleep(inDelayInMs); 102 | End 103 | End 104 | {$ENDREGION} 105 | Else 106 | Begin 107 | {$REGION 'Collect keystrokes required to type the full text and then send all inputs once, without any delay'} 108 | allinputs := TList.Create; 109 | Try 110 | For c In inText Do 111 | allinputs.AddRange(Self.InternalTranslateKey(c)); 112 | 113 | If allinputs.Count > 0 Then 114 | Begin 115 | inputs := allinputs.ToArray; 116 | 117 | SendInput(Length(inputs), inputs[0], SizeOf(TInput)); 118 | End; 119 | Finally 120 | FreeAndNil(allinputs); 121 | End; 122 | {$ENDREGION}; 123 | End; 124 | End; 125 | 126 | Class Function TAEVirtualKeyboard.KeyboardName: String; 127 | Begin 128 | Result := Self.InternalGetKeyboardName; 129 | End; 130 | 131 | Class Function TAEVirtualKeyboard.LanguageID: Cardinal; 132 | Begin 133 | // LCID 0 = current 134 | Result := 0; 135 | End; 136 | 137 | Procedure TAEVirtualKeyboard.TypeText(Const inText: String; inDelayInMs: Word = 10); 138 | Var 139 | oldstate, newstate: TKeyboardState; 140 | Begin 141 | // Sleeps only matter if we are not typing from the main thread. All SendInput calls are translated to WM_KEYDOWN and WM_KEYUP 142 | // window messages, which has to be processed before the result shows up. Therefore, only perform sleeps between keystrokes, 143 | // if we are NOT in the main thread of the application to avoid lockups. 144 | If GetCurrentThreadID = MainThreadID Then 145 | inDelayInMs := 0; 146 | 147 | {$REGION 'Save and reset keyboard state'} 148 | If Not GetKeyboardState(oldstate) Then 149 | RaiseLastOSError; 150 | 151 | ZeroMemory(@newstate, SizeOf(newstate)); 152 | 153 | If Not SetKeyboardState(newstate) Then 154 | RaiseLastOSError; 155 | {$ENDREGION} 156 | 157 | Try 158 | Self.InternalTypeText(inText, inDelayInMs); 159 | Finally 160 | {$REGION 'Restore previous keyboard state'} 161 | If Not SetKeyboardState(oldstate) Then 162 | RaiseLastOSError; 163 | {$ENDREGION} 164 | End; 165 | End; 166 | 167 | Initialization 168 | SetLength(_keyboards, 0); 169 | RegisterKeyboard(TAEVirtualKeyboard); 170 | 171 | End. 172 | -------------------------------------------------------------------------------- /AE.Misc/AE.Misc.FileUtils.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Misc.FileUtils; 10 | 11 | Interface 12 | 13 | Type 14 | TFileVersion = Record 15 | Debug: Boolean; 16 | VersionNumber: UInt64; 17 | MajorVersion: Word; 18 | MD5Hash: String; 19 | MinorVersion: Word; 20 | ReleaseVersion: Word; 21 | BuildNumber: Word; 22 | VersionString: String 23 | End; 24 | 25 | Function FileInfo(Const inFileName, inInfoName: String): String; 26 | Function FileProduct(Const inFileName: String): String; 27 | Function FileVersion(Const inFileName: String; Const inTranslateDebug: Boolean = False): TFileVersion; 28 | Function FileVersionToString(inFileVersion: UInt64; Const inDebug: Boolean = False): String; 29 | 30 | Implementation 31 | 32 | Uses WinApi.Windows, System.SysUtils, System.DateUtils, System.Hash; 33 | 34 | Type 35 | TTranslation = Record 36 | Language: Word; 37 | CharSet: Word; 38 | End; 39 | TTranslations = Array[0..20] Of TTranslation; 40 | PTranslations = ^TTranslations; 41 | 42 | Const 43 | MAJORDIV: UInt64 = 1000000000000000; // 100000^3 44 | MINORDIV: UInt64 = 10000000000; // 100000^2 45 | RELEASEDIV: UInt64 = 100000; // 100000^1 46 | 47 | Function FileInfo(Const inFileName, inInfoName: String): String; 48 | Var 49 | buf, value, infoname: PChar; 50 | len, n, count: Cardinal; 51 | trans: PTranslations; 52 | a: Integer; 53 | Begin 54 | Result := ''; 55 | 56 | n := GetFileVersionInfoSize(PChar(inFileName), n); 57 | If n = 0 Then 58 | Exit; 59 | 60 | buf := AllocMem(n); 61 | Try 62 | If Not GetFileVersionInfo(PChar(inFileName), 0, n, buf) Or 63 | Not VerQueryValue(Pointer(buf), '\VarFileInfo\Translation', Pointer(trans), count) Then 64 | Exit; 65 | 66 | For a := 0 To count Div SizeOf(TTranslation) - 1 Do 67 | Begin 68 | infoname := PChar('StringFileInfo\' + IntToHex(trans^[a].Language, 4) + IntToHex(trans^[a].CharSet,4) + '\' + inInfoName); 69 | 70 | If VerQueryValue(Pointer(buf), infoname, Pointer(value), len) Then 71 | Exit(Copy(value, 1, len)); 72 | End; 73 | Finally 74 | FreeMem(buf, n); 75 | End; 76 | End; 77 | 78 | Function FileProduct(Const inFileName: String): String; 79 | Begin 80 | Result := FileInfo(inFileName, 'ProductName'); 81 | End; 82 | 83 | Function FileVersion(Const inFileName: String; Const inTranslateDebug: Boolean = False): TFileVersion; 84 | Var 85 | len, n: Cardinal; 86 | buf, p: Pointer; 87 | fi: TVSFixedFileInfo; 88 | Begin 89 | Result.Debug := False; 90 | Result.VersionNumber := 0; 91 | Result.MajorVersion := 0; 92 | Result.MinorVersion := 0; 93 | Result.ReleaseVersion := 0; 94 | Result.BuildNumber := 0; 95 | Result.VersionString := ''; 96 | 97 | If FileExists(inFileName) Then 98 | Result.MD5Hash := THashMD5.GetHashStringFromFile(inFileName) 99 | Else 100 | Result.MD5Hash := ''; 101 | 102 | n := GetFileVersionInfoSize(PChar(inFileName), len); 103 | If n = 0 Then 104 | Exit; 105 | 106 | GetMem(buf, n); 107 | Try 108 | GetFileVersionInfo(PChar(inFileName), 0, n, buf); 109 | If Not VerQueryValue(buf, '\', p, len) Or (len <> SizeOf(TVSFixedFileInfo)) Then 110 | Exit; 111 | 112 | fi := PVSFixedFileInfo(p)^; 113 | 114 | Result.Debug := fi.dwFileFlags And VS_FF_DEBUG <> 0; 115 | If Not Result.Debug Or inTranslateDebug Then 116 | Begin 117 | Result.MajorVersion := HiWord(fi.dwFileVersionMS); 118 | Result.MinorVersion := LoWord(fi.dwFileVersionMS); 119 | Result.ReleaseVersion := HiWord(fi.dwFileVersionLS); 120 | Result.BuildNumber := LoWord(fi.dwFileVersionLS); 121 | 122 | Result.VersionNumber := Result.MajorVersion * MAJORDIV + 123 | Result.MinorVersion * MINORDIV + 124 | Result.ReleaseVersion * RELEASEDIV + 125 | Result.BuildNumber; 126 | 127 | Result.VersionString := FileVersionToString(Result.VersionNumber, Result.Debug); 128 | End; 129 | Finally 130 | FreeMem(buf, n); 131 | End; 132 | End; 133 | 134 | Function FileVersionToString(inFileVersion: UInt64; Const inDebug: Boolean = False): String; 135 | Var 136 | major, minor, release, build: Word; 137 | d: TDateTime; 138 | Begin 139 | major := inFileVersion Div MAJORDIV; 140 | inFileVersion := inFileVersion - (major * MAJORDIV); 141 | 142 | minor := inFileVersion Div MINORDIV; 143 | inFileVersion := inFileVersion - (minor * MINORDIV); 144 | 145 | release := inFileVersion Div RELEASEDIV; 146 | inFileVersion := inFileVersion - (release * RELEASEDIV); 147 | 148 | build := inFileVersion; 149 | 150 | If Not inDebug Then 151 | Result := Format('%d.%d.%d.%d', [major, minor, release, build]) 152 | Else 153 | Begin 154 | // From https://docwiki.embarcadero.com/RADStudio/Alexandria/en/Version_Info 155 | 156 | // Release = number of days since Jan 1 2000 157 | // Build = number of seconds since midnight (00:00:00), divided by 2 158 | 159 | d := IncSecond(IncDay(EncodeDateTime(2000, 1, 1, 0, 0, 0, 0), 160 | release), build * 2); 161 | Result := FormatDateTime('yymmdd.hhmm', d); 162 | End; 163 | End; 164 | 165 | End. 166 | -------------------------------------------------------------------------------- /AE.Comp/AE.Comp.ComboBox.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.ComboBox; 10 | 11 | Interface 12 | 13 | Uses Vcl.StdCtrls, System.Generics.Collections, System.Classes, WinApi.Messages, WinApi.Windows; 14 | 15 | Type 16 | TAEComboBox = Class(TComboBox) 17 | strict private 18 | _changecalled: Boolean; 19 | _closeupchange: Boolean; 20 | _dropdownchange: Boolean; 21 | _itemcache: TList; 22 | _timerwindow: HWnd; 23 | Procedure CBADDSTRING(Var Msg: TMessage); Message CB_ADDSTRING; 24 | Procedure CBINSERTSTRING(Var Msg: TMessage); Message CB_INSERTSTRING; 25 | Procedure CBDELETESTRING(Var Msg: TMessage); Message CB_DELETESTRING; 26 | Procedure CBRESETCONTENT(Var Msg: TMessage); Message CB_RESETCONTENT; 27 | Procedure CBSETITEMDATA(Var Msg: TMessage); Message CB_SETITEMDATA; 28 | Procedure ResetTimer(Const inTimerID: Integer); 29 | Procedure TimerWindowProc(Var inMessage: TMessage); 30 | protected 31 | Procedure Change; Override; 32 | Procedure CloseUp; Override; 33 | Procedure DropDown; Override; 34 | Procedure Select; Override; 35 | public 36 | Constructor Create(AOwner: TComponent); Override; 37 | Destructor Destroy; Override; 38 | published 39 | Property AutoDropDown Default True; 40 | End; 41 | 42 | Implementation 43 | 44 | Uses System.SysUtils, Vcl.Consts; 45 | 46 | Const 47 | TIMEREVENT_CLOSEUPCHANGE = 1; 48 | TIMEREVENT_REFRESHCACHE = 2; 49 | 50 | Procedure TAEComboBox.CBADDSTRING(Var Msg: TMessage); 51 | Begin 52 | inherited; 53 | 54 | ResetTimer(TIMEREVENT_REFRESHCACHE); 55 | End; 56 | 57 | Procedure TAEComboBox.CBDELETESTRING(Var Msg: TMessage); 58 | Begin 59 | inherited; 60 | 61 | ResetTimer(TIMEREVENT_REFRESHCACHE); 62 | End; 63 | 64 | Procedure TAEComboBox.CBINSERTSTRING(Var Msg: TMessage); 65 | Begin 66 | inherited; 67 | 68 | ResetTimer(TIMEREVENT_REFRESHCACHE); 69 | End; 70 | 71 | Procedure TAEComboBox.CBRESETCONTENT(Var Msg: TMessage); 72 | Begin 73 | inherited; 74 | 75 | ResetTimer(TIMEREVENT_REFRESHCACHE); 76 | End; 77 | 78 | Procedure TAEComboBox.CBSETITEMDATA(Var Msg: TMessage); 79 | Begin 80 | inherited; 81 | 82 | ResetTimer(TIMEREVENT_REFRESHCACHE); 83 | End; 84 | 85 | Procedure TAEComboBox.Change; 86 | Begin 87 | _changecalled := True; 88 | 89 | If _dropdownchange Then 90 | Begin 91 | If Self.Text <> Self.Items.Strings[Self.ItemIndex] Then 92 | Self.ItemIndex := _itemcache.IndexOf(String(Self.Text).ToLower); 93 | 94 | _dropdownchange := False; 95 | End; 96 | 97 | If Not _closeupchange And Not Self.DroppedDown And Self.AutoDropDown Then 98 | Begin 99 | SendMessage(Self.Handle, CB_SHOWDROPDOWN, Integer(True), 0); 100 | _closeupchange := False; 101 | End; 102 | 103 | inherited; 104 | End; 105 | 106 | Procedure TAEComboBox.CloseUp; 107 | Begin 108 | If Self.Style = csDropDown Then 109 | Begin 110 | _closeupchange := True; 111 | 112 | // If there is nothing selected OR the text in the box doesn't match the item shown by ItemIndex, set the index from cache 113 | If Self.ItemIndex = -1 Then 114 | Self.ItemIndex := _itemcache.IndexOf(String(Self.Text).ToLower); 115 | 116 | // If there is something selected and the text in the box doesn't match, correct the text 117 | If (Self.ItemIndex > -1) And 118 | (Self.Text <> Self.Items.Strings[Self.ItemIndex]) Then 119 | Self.Text := Self.Items[Self.ItemIndex] 120 | Else If (Self.ItemIndex = -1) And (Self.Text <> '') Then 121 | Self.Text := ''; 122 | End; 123 | 124 | inherited; 125 | 126 | If Self.Style = csDropDown Then 127 | ResetTimer(TIMEREVENT_CLOSEUPCHANGE); 128 | End; 129 | 130 | Constructor TAEComboBox.Create(AOwner: TComponent); 131 | Begin 132 | inherited; 133 | 134 | Self.AutoDropDown := True; 135 | 136 | _changecalled := False; 137 | 138 | _closeupchange := False; 139 | 140 | _dropdownchange := False; 141 | 142 | _itemcache := TList.Create; 143 | 144 | _timerwindow := AllocateHWnd(TimerWindowProc); 145 | End; 146 | 147 | Destructor TAEComboBox.Destroy; 148 | Begin 149 | FreeAndNil(_itemcache); 150 | 151 | DeallocateHWnd(_timerwindow); 152 | 153 | inherited; 154 | End; 155 | 156 | Procedure TAEComboBox.DropDown; 157 | Begin 158 | inherited; 159 | 160 | _dropdownchange := True; 161 | End; 162 | 163 | Procedure TAEComboBox.ResetTimer(Const inTimerID: Integer); 164 | Begin 165 | KillTimer(_timerwindow, inTimerID); 166 | 167 | If SetTimer(_timerwindow, inTimerID, 100, nil) = 0 Then 168 | Raise EOutOfResources.Create(SNoTimers); 169 | End; 170 | 171 | Procedure TAEComboBox.Select; 172 | Begin 173 | _changecalled := False; 174 | 175 | Try 176 | inherited; 177 | Finally 178 | If Not _changecalled Then 179 | Self.Change; 180 | End; 181 | End; 182 | 183 | Procedure TAEComboBox.TimerWindowProc(var inMessage: TMessage); 184 | Var 185 | s: String; 186 | Begin 187 | If inMessage.Msg = WM_TIMER Then 188 | Begin 189 | KillTimer(_timerwindow, inMessage.WParam); 190 | 191 | Case inMessage.WParam Of 192 | TIMEREVENT_CLOSEUPCHANGE: 193 | _closeupchange := False; 194 | TIMEREVENT_REFRESHCACHE: 195 | Begin 196 | _itemcache.Clear; 197 | 198 | If Self.Style = csDropDown Then 199 | For s In Self.Items Do 200 | _itemcache.Add(s.ToLower) 201 | Else 202 | _itemcache.Pack; 203 | End; 204 | End; 205 | 206 | inMessage.Result := 0; 207 | End 208 | Else 209 | DefWindowProc(_timerwindow, inMessage.Msg, inMessage.wParam, inMessage.lParam); 210 | End; 211 | 212 | End. 213 | -------------------------------------------------------------------------------- /AE.Misc/AE.MNB.ExchangeRates.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.MNB.ExchangeRates; 10 | 11 | Interface 12 | 13 | Uses System.Generics.Collections, System.Classes; 14 | 15 | Type 16 | TAEMNBExchangeRates = Class(TComponent) 17 | strict private 18 | _datadate: TDateTime; 19 | _rates: TDictionary; 20 | Function GetCurrencies: TArray; 21 | public 22 | Constructor Create(inOwner: TComponent); Override; 23 | Destructor Destroy; Override; 24 | Procedure RefreshRates; 25 | Function ExchangeRate(Const inCurrency: String): Double; Overload; 26 | Function ExchangeRate(Const inSourceCurrency, inTargetCurrency: String): Double; Overload; 27 | Property Currencies: TArray Read GetCurrencies; 28 | Property DataDate: TDateTime Read _datadate; 29 | End; 30 | 31 | Implementation 32 | 33 | Uses System.SysUtils, MNB.ExchangeRate.SoapService; 34 | 35 | Constructor TAEMNBExchangeRates.Create(inOwner: TComponent); 36 | Begin 37 | inherited; 38 | 39 | _datadate := Double.MinValue; 40 | _rates := TDictionary.Create; 41 | End; 42 | 43 | Destructor TAEMNBExchangeRates.Destroy; 44 | Begin 45 | FreeAndNil(_rates); 46 | 47 | inherited; 48 | End; 49 | 50 | Function TAEMNBExchangeRates.ExchangeRate(Const inSourceCurrency, inTargetCurrency: String): Double; 51 | Var 52 | srate, trate: Double; 53 | Begin 54 | Result := 0; 55 | 56 | If Not _rates.TryGetValue(inSourceCurrency, srate) Then 57 | Exit; 58 | 59 | If Not _rates.TryGetValue(inTargetCurrency, trate) Then 60 | Exit; 61 | 62 | Result := srate / trate; 63 | End; 64 | 65 | Function TAEMNBExchangeRates.GetCurrencies: TArray; 66 | Begin 67 | Result := _rates.Keys.ToArray; 68 | 69 | TArray.Sort(Result); 70 | End; 71 | 72 | Function TAEMNBExchangeRates.ExchangeRate(Const inCurrency: String): Double; 73 | Begin 74 | _rates.TryGetValue(inCurrency, Result); 75 | End; 76 | 77 | Procedure TAEMNBExchangeRates.RefreshRates; 78 | Const 79 | DAYDATE = '247,74195,53' + 103 | '68,87266,51387,81' + 104 | '52,1616,0951,33' + 105 | '382,44433,1545,27' + 106 | '2,34101,414,29' + 107 | '2,49269,1728,05' + 108 | '19,1481,7335,26' + 109 | '225,326,4879,95' + 110 | '78,033,264,81' + 111 | '34,48267,9810,51' + 112 | '18,869,67355,39' + 113 | '19,93'; 114 | {$ELSE} 115 | GetMNBArfolyamServiceSoap.GetCurrentExchangeRates; 116 | {$ENDIF} 117 | 118 | fs := TFormatSettings.Create; 119 | fs.DateSeparator := '-'; 120 | fs.ShortDateFormat := 'yyyy-mm-dd'; 121 | fs.DecimalSeparator := ','; 122 | 123 | // As the returned document is fairly simple and straightforward there's no need to process it as IXMLDocument (yet). 124 | // Finding the necessary data as string will be more resource (and thread) friendly 125 | 126 | cpos := xml.IndexOf(DAYDATE); 127 | 128 | If cpos = -1 Then 129 | Exit; 130 | 131 | If Not TryStrToDate(xml.Substring(cpos + DAYDATE.Length, fs.ShortDateFormat.Length), _datadate, fs) Then 132 | Exit; 133 | 134 | Repeat 135 | cpos := xml.IndexOf(RATEUNIT, cpos); 136 | 137 | If cpos <> -1 Then 138 | Begin 139 | Inc(cpos, RATEUNIT.Length); 140 | 141 | If Not Integer.TryParse(xml.Substring(cpos, xml.IndexOf('"', cpos) - cpos), cunit) Then 142 | Continue; 143 | 144 | cpos := xml.IndexOf(CURRNAME, cpos); 145 | 146 | If cpos <> -1 Then 147 | Begin 148 | Inc(cpos, CURRNAME.Length); 149 | 150 | cname := xml.Substring(cpos, xml.IndexOf('"', cpos) - cpos); 151 | 152 | cpos := xml.IndexOf('>', cpos); 153 | 154 | If cpos <> -1 Then 155 | Begin 156 | Inc(cpos); 157 | 158 | If Not Double.TryParse(xml.Substring(cpos, xml.IndexOf('<', cpos) - cpos), crate, fs) Then 159 | Continue; 160 | 161 | _rates.Add(cname, crate / cunit); 162 | End; 163 | End; 164 | End; 165 | Until cpos = -1; 166 | End; 167 | 168 | End. 169 | -------------------------------------------------------------------------------- /AE.Application/AE.Application.Console.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Application.Console; 10 | 11 | Interface 12 | 13 | {$IFDEF MSWINDOWS} 14 | Uses AE.Application.Application; 15 | 16 | Procedure StartWithConsole(inAEApplicationClass: TAEApplicationClass); 17 | {$ENDIF} 18 | 19 | Implementation 20 | 21 | {$IFDEF MSWINDOWS} 22 | Uses WinApi.Windows, System.SysUtils, AE.Application.Helper; 23 | 24 | Type 25 | TConsole = Class 26 | Class Procedure Log(inMessage: String = ''); 27 | End; 28 | 29 | Var 30 | ConsoleHandle: THandle; 31 | TerminateSignalreceived, Ended, ConsoleHandlerEnded, WaitForKey, 32 | OSShutdown: Boolean; 33 | LogCS: TRTLCriticalSection; 34 | ConsoleBufferInfo: Console_Screen_Buffer_Info; 35 | 36 | Class Procedure TConsole.Log(inMessage: String = ''); 37 | Var 38 | textcolor: Word; 39 | nocolor, color: String; 40 | Begin 41 | EnterCriticalSection(LogCS); 42 | Try 43 | If inMessage.ToLower.Contains(' raised ') Or 44 | inMessage.ToLower.Contains('exception ') Or 45 | inMessage.ToLower.Contains(' terminate') Or 46 | inMessage.ToLower.Contains(' fail') Or inMessage.ToLower.Contains 47 | (' error ') Then 48 | textcolor := FOREGROUND_RED Or FOREGROUND_INTENSITY // RED 49 | Else If inMessage.Contains('[') And inMessage.Contains(']') And 50 | Not inMessage.ToLower.Contains('starting up') Then 51 | textcolor := FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY 52 | // Yellow 53 | Else If inMessage.ToLower.Contains(' success') Then 54 | textcolor := FOREGROUND_GREEN Or FOREGROUND_INTENSITY // Green 55 | Else 56 | textcolor := ConsoleBufferInfo.wAttributes; 57 | If inMessage.Contains(' - ') Then 58 | Begin 59 | nocolor := inMessage.Substring(0, inMessage.IndexOf(' - ') + 3); 60 | color := inMessage.Substring(inMessage.IndexOf(' - ') + 3); 61 | End 62 | Else 63 | Begin 64 | nocolor := ''; 65 | color := inMessage; 66 | End; 67 | Write(nocolor); 68 | If textcolor <> ConsoleBufferInfo.wAttributes Then 69 | SetConsoleTextAttribute(ConsoleHandle, textcolor); 70 | WriteLn(color); 71 | If textcolor <> ConsoleBufferInfo.wAttributes Then 72 | SetConsoleTextAttribute(ConsoleHandle, ConsoleBufferInfo.wAttributes); 73 | Flush(OUTPUT); 74 | Finally 75 | LeaveCriticalSection(LogCS); 76 | End; 77 | End; 78 | 79 | Function ConsoleFound: Boolean; 80 | Begin 81 | ConsoleHandle := GetStdHandle(Std_Output_Handle); 82 | If ConsoleHandle = Invalid_Handle_Value Then 83 | RaiseLastOSError; 84 | Result := ConsoleHandle <> 0; 85 | End; 86 | 87 | Function console_handler(inCtrlType: DWORD): Bool; StdCall; 88 | Begin 89 | If TerminateSignalreceived Then 90 | Exit(True); 91 | TConsole.Log; 92 | Case inCtrlType Of 93 | CTRL_C_EVENT: 94 | TConsole.Log('Ctrl-C caught!'); 95 | CTRL_BREAK_EVENT: 96 | TConsole.Log('Ctrl-Break caught!'); 97 | CTRL_CLOSE_EVENT: 98 | TConsole.Log('Console exit caught!'); 99 | CTRL_LOGOFF_EVENT: 100 | TConsole.Log('User logoff event caught!'); 101 | CTRL_SHUTDOWN_EVENT: 102 | Begin 103 | OSShutdown := True; 104 | TConsole.Log('Shutdown event caught!'); 105 | End; 106 | End; 107 | WaitForKey := Not((inCtrlType = CTRL_CLOSE_EVENT) Or 108 | (inCtrlType = CTRL_LOGOFF_EVENT) Or (inCtrlType = CTRL_SHUTDOWN_EVENT)); 109 | TerminateSignalreceived := True; // Signal main program that we should quit 110 | While Not Ended Do // Wait for clean shutdown 111 | Sleep(50); 112 | Result := True; 113 | ConsoleHandlerEnded := True; 114 | // Signal main program that console handler finished 115 | End; 116 | 117 | Procedure StartWithConsole(inAEApplicationClass: TAEApplicationClass); 118 | Var 119 | aeapp: TAEApplication; 120 | consoleallocated: Boolean; 121 | Begin 122 | InitializeCriticalSection(LogCS); 123 | Try 124 | Try 125 | consoleallocated := Not ConsoleFound; 126 | If consoleallocated Then 127 | Begin 128 | AllocConsole; 129 | ConsoleFound; 130 | End; 131 | Try 132 | // SetConsoleTitle(PChar(AESHMClass.ServiceDisplayName + ' ' + TranslateFileVersion(ParamStr(0)))); 133 | GetConsoleScreenBufferInfo(ConsoleHandle, ConsoleBufferInfo); 134 | Ended := False; 135 | ConsoleHandlerEnded := False; 136 | TerminateSignalreceived := False; 137 | WaitForKey := True; 138 | OSShutdown := False; 139 | TConsole.Log('Setting up console handler...'); 140 | If Not SetConsoleCtrlHandler(@console_handler, True) Then 141 | RaiseLastOSError; 142 | Try 143 | TConsole.Log('Press Ctrl-C or Ctrl-Break to send a terminate signal'); 144 | TConsole.Log; 145 | aeapp := inAEApplicationClass.Create(TConsole.Log); 146 | Try 147 | Repeat 148 | CustomMessagePump; 149 | Sleep(100); 150 | Until TerminateSignalreceived; 151 | aeapp.OSShutdown := OSShutdown; 152 | Finally 153 | TConsole.Log; 154 | aeapp.Free; 155 | End; 156 | Ended := True; 157 | // Signal console handler that clean shutdown is completed 158 | While Not ConsoleHandlerEnded Do 159 | // Wait for console handler to finish... 160 | Sleep(50); 161 | If WaitForKey Then 162 | Begin 163 | TConsole.Log; 164 | TConsole.Log('Press Enter to exit.'); 165 | ReadLn; 166 | End; 167 | Finally 168 | TConsole.Log('Removing console handler...'); 169 | If Not SetConsoleCtrlHandler(@console_handler, False) Then 170 | RaiseLastOSError; 171 | End; 172 | Finally 173 | If consoleallocated Then 174 | FreeConsole; 175 | End; 176 | Except 177 | On E: Exception Do 178 | TConsole.Log(E.ClassName + ' was raised with the message ' + E.Message); 179 | End; 180 | Finally 181 | DeleteCriticalSection(LogCS); 182 | End; 183 | End; 184 | {$ENDIF} 185 | 186 | End. 187 | -------------------------------------------------------------------------------- /AE.VirtualKeyboard/AE.VirtualKeyboard.HuHu.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.VirtualKeyboard.HuHu; 10 | 11 | Interface 12 | 13 | Uses AE.VirtualKeyboard.Foreign, AE.VirtualKeyboard, System.SysUtils; 14 | 15 | Type 16 | TAEVirtualHuHuKeyboard = Class(TAEVirtualForeignKeyboard) 17 | strict protected 18 | Class Function LanguageID: Cardinal; Override; 19 | Function InternalTranslateForeignKey(Const inKey: Char): TInputs; Override; 20 | End; 21 | 22 | Implementation 23 | 24 | Type 25 | TSpecialKey = (skNone, skShift, skAltGr); 26 | 27 | Function TAEVirtualHuHuKeyboard.InternalTranslateForeignKey(Const inKey: Char): TInputs; 28 | Var 29 | code: Word; 30 | kpos: Integer; 31 | speckey: TSpecialKey; 32 | Begin 33 | SetLength(Result, 0); 34 | 35 | speckey := skNone; 36 | code := Ord(inKey); 37 | 38 | {$REGION 'Change key code and shift state for specific keys'} 39 | Case inKey Of 40 | '!': 41 | Begin 42 | speckey := skShift; 43 | code := 52; 44 | End; 45 | '"': 46 | Begin 47 | speckey := skShift; 48 | code := 50; 49 | End; 50 | '#': 51 | Begin 52 | speckey := skAltGr; 53 | code := 88; 54 | End; 55 | '$': 56 | Begin 57 | speckey := skAltGr; 58 | code := 186; 59 | End; 60 | '%': 61 | Begin 62 | speckey := skShift; 63 | code := 53; 64 | End; 65 | '&': 66 | Begin 67 | speckey := skAltGr; 68 | code := 67; 69 | End; 70 | '''': 71 | Begin 72 | speckey := skShift; 73 | code := 49; 74 | End; 75 | '(': 76 | Begin 77 | speckey := skShift; 78 | code := 56; 79 | End; 80 | ')': 81 | Begin 82 | speckey := skShift; 83 | code := 57; 84 | End; 85 | '*': 86 | Begin 87 | speckey := skAltGr; 88 | code := 189; 89 | End; 90 | '+': 91 | Begin 92 | speckey := skShift; 93 | code := 51; 94 | End; 95 | ',': 96 | code := 188; 97 | '-': 98 | code := 189; 99 | '.': 100 | code := 190; 101 | '/': 102 | Begin 103 | speckey := skShift; 104 | code := 54; 105 | End; 106 | ':': 107 | Begin 108 | speckey := skShift; 109 | code := 190; 110 | End; 111 | ';': 112 | Begin 113 | speckey := skAltGr; 114 | code := 188; 115 | End; 116 | '<': 117 | Begin 118 | speckey := skAltGr; 119 | code := 226; 120 | End; 121 | '=': 122 | Begin 123 | speckey := skShift; 124 | code := 55; 125 | End; 126 | '>': 127 | Begin 128 | speckey := skAltGr; 129 | code := 89; 130 | End; 131 | '?': 132 | Begin 133 | speckey := skShift; 134 | code := 188; 135 | End; 136 | '@': 137 | Begin 138 | speckey := skAltGr; 139 | code := 86; 140 | End; 141 | 'A'..'Z': 142 | speckey := skShift; 143 | '[': 144 | Begin 145 | speckey := skAltGr; 146 | code := 70; 147 | End; 148 | '\': 149 | Begin 150 | speckey := skAltGr; 151 | code := 81; 152 | End; 153 | ']': 154 | Begin 155 | speckey := skAltGr; 156 | code := 71; 157 | End; 158 | '_': 159 | Begin 160 | speckey := skShift; 161 | code := 189; 162 | End; 163 | 'a'..'z': 164 | code := code - 32; 165 | '{': 166 | Begin 167 | speckey := skAltGr; 168 | code := 66; 169 | End; 170 | '|': 171 | Begin 172 | speckey := skAltGr; 173 | code := 87; 174 | End; 175 | '}': 176 | Begin 177 | speckey := skAltGr; 178 | code := 78; 179 | End; 180 | '~': 181 | Begin 182 | speckey := skAltGr; 183 | code := 49; 184 | End; 185 | '€': 186 | Begin 187 | speckey := skAltGr; 188 | code := 85; 189 | End; 190 | 'Á': 191 | Begin 192 | speckey := skShift; 193 | code := 222; 194 | End; 195 | 'É': 196 | Begin 197 | speckey := skShift; 198 | code := 186; 199 | End; 200 | 'Í': 201 | Begin 202 | speckey := skShift; 203 | code := 226; 204 | End; 205 | 'Ó': 206 | Begin 207 | speckey := skShift; 208 | code := 187; 209 | End; 210 | 'Ö': 211 | Begin 212 | speckey := skShift; 213 | code := 192; 214 | End; 215 | 'Ú': 216 | Begin 217 | speckey := skShift; 218 | code := 221; 219 | End; 220 | 'Ü': 221 | Begin 222 | speckey := skShift; 223 | code := 191; 224 | End; 225 | 'Ő': 226 | Begin 227 | speckey := skShift; 228 | code := 219; 229 | End; 230 | 'Ű': 231 | Begin 232 | speckey := skShift; 233 | code := 220; 234 | End; 235 | 'á': 236 | code := 222; 237 | 'é': 238 | code := 186; 239 | 'í': 240 | code := 226; 241 | 'ó': 242 | code := 187; 243 | 'ö': 244 | code := 192; 245 | 'ú': 246 | code := 221; 247 | 'ü': 248 | code := 191; 249 | 'ő': 250 | code := 219; 251 | 'ű': 252 | code := 220; 253 | End; 254 | {$ENDREGION} 255 | 256 | Case speckey Of 257 | skNone: 258 | Begin 259 | SetLength(Result, 2); 260 | 261 | kpos := 0; 262 | End; 263 | skShift: 264 | Begin 265 | SetLength(Result, 4); 266 | 267 | kpos := 1; 268 | 269 | Result[0] := KeyInput(16, vkbPress); // Press Shift 270 | Result[3] := KeyInput(16, vkbRelease); // Release Shift 271 | End; 272 | skAltGr: 273 | Begin 274 | SetLength(Result, 6); 275 | 276 | kpos := 2; 277 | 278 | Result[0] := KeyInput(17, vkbPress); // Press Ctrl 279 | Result[1] := KeyInput(18, vkbPress); // Press Alt 280 | Result[4] := KeyInput(18, vkbRelease); // Release Alt 281 | Result[5] := KeyInput(17, vkbRelease); // Release Ctrl 282 | End; 283 | Else 284 | Exit; 285 | End; 286 | 287 | Result[kpos] := KeyInput(code, vkbPress); 288 | Result[kpos + 1] := KeyInput(code, vkbRelease); 289 | End; 290 | 291 | Class Function TAEVirtualHuHuKeyboard.LanguageID: Cardinal; 292 | Begin 293 | Result := 1038; 294 | End; 295 | 296 | Initialization 297 | RegisterKeyboard(TAEVirtualHuHuKeyboard); 298 | 299 | End. 300 | -------------------------------------------------------------------------------- /AE.Comp/AE.Comp.ThreadedTimer.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.ThreadedTimer; 10 | 11 | Interface 12 | 13 | Uses System.Classes; 14 | 15 | Type 16 | TAEThreadedTimer = Class(TComponent) 17 | strict private 18 | _enabled: Boolean; 19 | _thread: TThread; 20 | _ontimer: TNotifyEvent; 21 | Procedure ThreadTimer; 22 | Procedure SetEnabled(Const inEnabled: Boolean); 23 | Procedure SetInterval(Const inInterval: Integer); 24 | Procedure SetOnTimer(Const inOnTimer: TNotifyEvent); 25 | Function GetInterval: Integer; 26 | public 27 | Constructor Create(AOwner: TComponent); Override; 28 | Destructor Destroy; Override; 29 | published 30 | Property Enabled: Boolean Read _enabled Write SetEnabled Default True; 31 | Property Interval: Integer Read GetInterval Write SetInterval Default 1000; 32 | Property OnTimer: TNotifyEvent Read _ontimer Write SetOnTimer; 33 | End; 34 | 35 | Implementation 36 | 37 | Uses WinApi.Windows, System.SysUtils; 38 | 39 | Type 40 | TTimerThread = Class(TThread) 41 | strict private 42 | _events: Array [0 .. 2] Of THandle; // Enabled - Cancelled - Restar timer 43 | _ontimer: TThreadProcedure; 44 | _interval: Integer; 45 | Procedure SetEnabled(Const inEnabled: Boolean); 46 | Procedure SetInterval(Const inInterval: Integer); 47 | Function GetEnabled: Boolean; 48 | protected 49 | Procedure Execute; Override; 50 | Procedure TerminatedSet; Override; 51 | public 52 | Constructor Create; 53 | Destructor Destroy; Override; 54 | Property Enabled: Boolean Read GetEnabled Write SetEnabled; 55 | Property Interval: Integer Read _interval Write SetInterval; 56 | Property OnTimer: TThreadProcedure Read _ontimer Write _ontimer; 57 | End; 58 | 59 | // 60 | // TTimerThread 61 | // 62 | 63 | Constructor TTimerThread.Create; 64 | Begin 65 | inherited Create(False); 66 | 67 | _events[0] := CreateEvent(nil, True, False, nil); // Enabled flag 68 | _events[1] := CreateEvent(nil, True, False, nil); // Cancelled flag 69 | _events[2] := CreateEvent(nil, True, False, nil); // Restar timer flag 70 | 71 | _ontimer := nil; 72 | _interval := 1000; 73 | Self.FreeOnTerminate := False; 74 | Self.Enabled := True; 75 | End; 76 | 77 | Destructor TTimerThread.Destroy; 78 | Begin 79 | Self.Terminate; 80 | 81 | If GetCurrentThreadID = MainThreadID Then 82 | Self.Waitfor; 83 | 84 | CloseHandle(_events[2]); // Restar timer flag 85 | CloseHandle(_events[1]); // Cancelled flag 86 | CloseHandle(_events[0]); // Enabled flag 87 | 88 | inherited; 89 | End; 90 | 91 | Procedure TTimerThread.SetEnabled(Const inEnabled: Boolean); 92 | Begin 93 | // Enabled flag 94 | If inEnabled Then 95 | SetEvent(_events[0]) 96 | Else 97 | ResetEvent(_events[0]); 98 | 99 | SetEvent(_events[2]); // Restar timer flag 100 | End; 101 | 102 | Procedure TTimerThread.SetInterval(Const inInterval: Integer); 103 | Begin 104 | _interval := inInterval; 105 | 106 | SetEvent(_events[2]); // Restar timer flag 107 | End; 108 | 109 | Procedure TTimerThread.TerminatedSet; 110 | Begin 111 | inherited; 112 | 113 | ResetEvent(_events[0]); // Enabled flag 114 | SetEvent(_events[1]); // Cancelled flag 115 | SetEvent(_events[2]); // Restar timer flag 116 | End; 117 | 118 | Procedure TTimerThread.Execute; 119 | Var 120 | winterval, lastexectime: Int64; 121 | freq, scount, ecount: Int64; 122 | Begin 123 | QueryPerformanceFrequency(freq); 124 | 125 | lastexectime := 0; 126 | While Not Terminated Do 127 | Begin 128 | // Wait for the Enabled and Cancelled flags for an infinite amount of time. If not Object_0 (Enabled) was 129 | // signaled (thus, the timer thread was cancelled) exit the thread immediately. 130 | If WaitForMultipleObjects(2, @_events[0], False, INFINITE) <> 131 | WAIT_OBJECT_0 Then 132 | Break; 133 | 134 | If Assigned(_ontimer) Then 135 | Begin 136 | winterval := _interval - lastexectime; 137 | If (winterval < 0) Then 138 | winterval := 0; 139 | 140 | ResetEvent(_events[2]); // Enabled reset 141 | 142 | // Wait for Cancelled and Restart Timer flags for "winterval" amount of time. 143 | // Possible outcomes: 144 | // Object_0 (Cancelled flag) was signaled - exit the thread immediately 145 | // Object_1 (Reset timer flag) was signaled - don't call the OnTimer event but go for the next cycle 146 | // Wait_Timeout - No flags were signaled, OnTimer event can be called 147 | 148 | Case WaitForMultipleObjects(2, @_events[1], False, winterval) Of 149 | WAIT_OBJECT_0: // Cancelled flag 150 | Break; 151 | WAIT_TIMEOUT: 152 | Begin 153 | If Self.Enabled Then 154 | Begin 155 | QueryPerformanceCounter(scount); 156 | Synchronize(_ontimer); 157 | QueryPerformanceCounter(ecount); 158 | lastexectime := 1000 * (ecount - scount) Div freq; 159 | End; 160 | End; 161 | End; 162 | End; 163 | End; 164 | End; 165 | 166 | Function TTimerThread.GetEnabled: Boolean; 167 | Begin 168 | Result := Not Self.Terminated And 169 | (WaitForSingleObject(_events[0], 0) = WAIT_OBJECT_0); 170 | End; 171 | 172 | // 173 | // TAEThreadedTimer 174 | // 175 | 176 | Constructor TAEThreadedTimer.Create(AOwner: TComponent); 177 | Begin 178 | inherited; 179 | 180 | _ontimer := nil; 181 | 182 | _thread := TTimerThread.Create; 183 | TTimerThread(_thread).OnTimer := Self.ThreadTimer; 184 | Self.Enabled := True; 185 | Self.Interval := 1000; 186 | End; 187 | 188 | Destructor TAEThreadedTimer.Destroy; 189 | Begin 190 | If Assigned(_thread) Then 191 | Begin 192 | _thread.Terminate; 193 | _thread.Waitfor; 194 | FreeAndNil(_thread); 195 | End; 196 | 197 | inherited; 198 | End; 199 | 200 | Function TAEThreadedTimer.GetInterval: Integer; 201 | Begin 202 | Result := TTimerThread(_thread).Interval; 203 | End; 204 | 205 | Procedure TAEThreadedTimer.ThreadTimer; 206 | Begin 207 | If Assigned(_ontimer) Then 208 | _ontimer(Self); 209 | End; 210 | 211 | Procedure TAEThreadedTimer.SetEnabled(Const inEnabled: Boolean); 212 | Begin 213 | _enabled := inEnabled; 214 | 215 | TTimerThread(_thread).Enabled := _enabled And Assigned(_ontimer); 216 | End; 217 | 218 | Procedure TAEThreadedTimer.SetInterval(Const inInterval: Integer); 219 | Begin 220 | TTimerThread(_thread).Interval := inInterval; 221 | End; 222 | 223 | Procedure TAEThreadedTimer.SetOnTimer(Const inOnTimer: TNotifyEvent); 224 | Begin 225 | _ontimer := inOnTimer; 226 | 227 | TTimerThread(_thread).Enabled := _enabled And Assigned(_ontimer); 228 | End; 229 | 230 | End. 231 | -------------------------------------------------------------------------------- /AE.Misc/AE.Helper.TBytes.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2023 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Helper.TBytes; 10 | 11 | Interface 12 | 13 | Uses System.SysUtils; 14 | 15 | Type 16 | TBytesHelper = Record Helper for TBytes 17 | public 18 | Class Function FromHexString(Const inHexString: String): TBytes; 19 | Class Function FromString(Const inString: String; Const inTryDecompress: Boolean = False): TBytes; 20 | Class Function IsEqual(Const inBytes1, inBytes2: TBytes): Boolean; Overload; 21 | Class Function ToString(Const inBytes: TBytes; Const inCompress: Boolean = False): String; Overload; 22 | Procedure Clear; InLine; 23 | Procedure Compress; 24 | Procedure Decompress; 25 | Procedure Insert(inPosition: NativeInt; Const inBytes: TBytes); 26 | Function Clone: TBytes; 27 | Function Data: Pointer; 28 | Function IsEmpty: Boolean; 29 | Function IsEqual(Const inBytes: TBytes): Boolean; Overload; 30 | Function Length: Integer; InLine; 31 | Function Range(Const inStartIndex, inLength: NativeInt): TBytes; Overload; 32 | Function Range(Const inStartIndex: NativeInt): TBytes; Overload; 33 | Function ToHexString: String; 34 | Function ToString(Const inCompress: Boolean = False): String; Overload; 35 | End; 36 | 37 | Implementation 38 | 39 | Uses System.ZLib, System.Classes, System.NetEncoding; 40 | 41 | Function TBytesHelper.Range(Const inStartIndex, inLength: NativeInt): TBytes; 42 | Begin 43 | SetLength(Result, inLength); 44 | 45 | Move(Self[inStartIndex], Result[0], inLength); 46 | End; 47 | 48 | Procedure TBytesHelper.Clear; 49 | Begin 50 | If Self.Length = 0 Then 51 | Exit; 52 | 53 | FillChar(Self[0], Self.Length, #0); 54 | SetLength(Self, 0); 55 | End; 56 | 57 | Function TBytesHelper.Clone: TBytes; 58 | Begin 59 | SetLength(Result, Self.Length); 60 | 61 | If Not Self.IsEmpty Then 62 | Move(Self[0], Result[0], Self.Length); 63 | End; 64 | 65 | Procedure TBytesHelper.Compress; 66 | Var 67 | compressor: TZCompressionStream; 68 | output: TBytesStream; 69 | Begin 70 | output := TBytesStream.Create; 71 | Try 72 | compressor := TZCompressionStream.Create(clMax, output); 73 | Try 74 | compressor.Write(Self, Self.Length); 75 | Finally 76 | FreeAndNil(compressor); 77 | End; 78 | 79 | // 2 bytes = ZLib header which is always the same: $78 $01 (fastest) / $9C (default) / $DA (max) 80 | // Our compression method is using clMax, so the first two bytes are ALWAYS going to be $78 $DA 81 | // Upon decompression we simply can write these two bytes back so we can save on transfer / storage! 82 | 83 | output.Position := 2; 84 | SetLength(Self, output.Size - 2); 85 | output.Read(Self[0], output.Size - 2); 86 | Finally 87 | FreeAndNil(output); 88 | End; 89 | End; 90 | 91 | Function TBytesHelper.Data: Pointer; 92 | Begin 93 | Result := @Self[0]; 94 | End; 95 | 96 | Procedure TBytesHelper.Decompress; 97 | Var 98 | compressor: TZDecompressionStream; 99 | input: TBytesStream; 100 | zlibheader: TBytes; 101 | Begin 102 | input := TBytesStream.Create; 103 | Try 104 | // 2 bytes = ZLib header which is always the same: $78 $01 (fastest) / $9C (default) / $DA (max) 105 | // Our compression method cuts down the header to further decrease the size so we simply can 106 | // add it back 107 | // 108 | // For backwards compatibility a check if implemented: to prevent this if the header is already 109 | // present. In a couple of builds we can get rid of that, too 110 | 111 | zlibheader := [$78, $DA]; 112 | input.Write(zlibheader[0], 2); 113 | 114 | input.Write(Self, Self.Length); 115 | input.Position := 0; 116 | compressor := TZDecompressionStream.Create(input); 117 | Try 118 | SetLength(Self, compressor.Size); 119 | compressor.Read(Self, Self.Length); 120 | Finally 121 | FreeAndNil(compressor); 122 | End; 123 | Finally 124 | FreeAndNil(input); 125 | End; 126 | End; 127 | 128 | Class Function TBytesHelper.FromHexString(Const inHexString: String): TBytes; 129 | Begin 130 | SetLength(Result, inHexString.Length Div SizeOf(Char)); 131 | 132 | HexToBin(PWideChar(inHexString), Result[0], inHexString.Length Div SizeOf(Char)); 133 | End; 134 | 135 | Class Function TBytesHelper.FromString(Const inString: String; Const inTryDecompress: Boolean): TBytes; 136 | Begin 137 | Result := TNetEncoding.Base64.DecodeStringToBytes(inString); 138 | 139 | If inTryDecompress Then 140 | Result.Decompress; 141 | End; 142 | 143 | Class Function TBytesHelper.ToString(Const inBytes: TBytes; Const inCompress: Boolean = False): String; 144 | Var 145 | tmp: TBytes; 146 | Begin 147 | tmp := inBytes.Clone; 148 | 149 | If inCompress Then 150 | tmp.Compress; 151 | 152 | Result := TNetEncoding.Base64.EncodeBytesToString(tmp).Replace(sLineBreak, '').Replace('=', ''); 153 | End; 154 | 155 | Procedure TBytesHelper.Insert(inPosition: NativeInt; Const inBytes: TBytes); 156 | Var 157 | appendtoend: Boolean; 158 | Begin 159 | appendtoend := inPosition = Self.Length - 1; 160 | 161 | SetLength(Self, Self.Length + inBytes.Length); 162 | 163 | If Not appendtoend Then 164 | // Move the data from inPosition to the end of the array 165 | Move(Self[inPosition], Self[inPosition + inBytes.Length], Self.Length - inPosition) 166 | Else 167 | // We have to increase inPosition with one to avoid overwriting the last value 168 | Inc(inPosition, 1); 169 | 170 | // Copy inBytes to Self, to position inPosition 171 | Move(inBytes[0], Self[inPosition], inBytes.Length); 172 | End; 173 | 174 | Function TBytesHelper.IsEmpty: Boolean; 175 | Begin 176 | Result := Self.Length = 0; 177 | End; 178 | 179 | Function TBytesHelper.IsEqual(Const inBytes: TBytes): Boolean; 180 | Begin 181 | Result := TBytes.IsEqual(Self, inBytes); 182 | End; 183 | 184 | Class Function TBytesHelper.IsEqual(Const inBytes1, inBytes2: TBytes): Boolean; 185 | Begin 186 | Result := (inBytes1.Length = inBytes2.Length) And CompareMem(inBytes1.Data, inBytes2.Data, inBytes1.Length); 187 | End; 188 | 189 | Function TBytesHelper.Length: Integer; 190 | Begin 191 | Result := System.Length(Self); 192 | End; 193 | 194 | Function TBytesHelper.Range(Const inStartIndex: NativeInt): TBytes; 195 | Begin 196 | Result := Self.Range(inStartIndex, Self.Length - inStartIndex); 197 | End; 198 | 199 | Function TBytesHelper.ToHexString: String; 200 | Begin 201 | SetLength(Result, Self.Length * SizeOf(Char)); 202 | 203 | BinToHex(Self[0], PWideChar(Result), Self.Length); 204 | End; 205 | 206 | Function TBytesHelper.ToString(Const inCompress: Boolean): String; 207 | Begin 208 | Result := TBytes.ToString(Self, inCompress); 209 | End; 210 | 211 | End. 212 | -------------------------------------------------------------------------------- /AE.Application/AE.Application.Settings.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Application.Settings; 10 | 11 | Interface 12 | 13 | Uses System.JSON, System.SysUtils, AE.Application.Setting; 14 | 15 | Type 16 | TSettingsFileLocation = (slNextToExe, slAppData, slDocuments); 17 | 18 | TSettingsFileCompresion = (scAutoDetect, scUncompressed, scCompressed); 19 | 20 | TAEApplicationSettings = Class(TAEApplicationSetting) 21 | strict private 22 | _destroying: Boolean; 23 | _loaded: Boolean; 24 | _loading: Boolean; 25 | _settingsfilename: String; 26 | _settingsmigrated: Boolean; 27 | _compressed: Boolean; 28 | Procedure SetFileBytes(Const inBytes: TBytes); 29 | Function GetFileBytes: TBytes; 30 | strict protected 31 | Procedure AfterLoad; Virtual; 32 | Procedure AfterSave; Virtual; 33 | Procedure BeforeLoad(Var outByteArray: TBytes); Virtual; 34 | Procedure BeforeSave(Var outByteArray: TBytes); Virtual; 35 | Procedure InternalClear; Override; 36 | Procedure SettingsMigrated; 37 | public 38 | Class Function SettingsFileDir(Const inFileLocation: TSettingsFileLocation): String; 39 | Class Function New(Const inFileLocation: TSettingsFileLocation; Const inCompression: TSettingsFileCompresion = scAutoDetect): TAEApplicationSettings; 40 | Constructor Create(Const inSettingsFileName: String); ReIntroduce; Virtual; 41 | Procedure BeforeDestruction; Override; 42 | Procedure Load; 43 | Procedure Save; 44 | Property Compressed: Boolean Read _compressed Write _compressed; 45 | Property FileBytes: TBytes Read GetFileBytes Write SetFileBytes; 46 | Property IsLoaded: Boolean Read _loaded; 47 | Property SettingsFileName: String Read _settingsfilename; 48 | End; 49 | 50 | Implementation 51 | 52 | Uses System.IOUtils, AE.Helper.TBytes, System.Classes; 53 | 54 | Procedure TAEApplicationSettings.InternalClear; 55 | Begin 56 | _loaded := False; 57 | If Not _loading Then 58 | _settingsmigrated := False; 59 | End; 60 | 61 | Procedure TAEApplicationSettings.AfterLoad; 62 | Begin 63 | // Dummy 64 | End; 65 | 66 | Procedure TAEApplicationSettings.AfterSave; 67 | Begin 68 | // Dummy 69 | End; 70 | 71 | Procedure TAEApplicationSettings.BeforeDestruction; 72 | Begin 73 | inherited; 74 | 75 | _destroying := True; 76 | End; 77 | 78 | Procedure TAEApplicationSettings.BeforeLoad(Var outByteArray: TBytes); 79 | Begin 80 | // Dummy 81 | End; 82 | 83 | Procedure TAEApplicationSettings.BeforeSave(Var outByteArray: TBytes); 84 | Begin 85 | // Dummy 86 | End; 87 | 88 | Constructor TAEApplicationSettings.Create(Const inSettingsFileName: String); 89 | Begin 90 | _settingsfilename := inSettingsFileName; 91 | _destroying := False; 92 | _loading := False; 93 | _compressed := {$IFDEF DEBUG}False{$ELSE}True{$ENDIF}; 94 | 95 | inherited Create; 96 | End; 97 | 98 | Function TAEApplicationSettings.GetFileBytes: TBytes; 99 | Begin 100 | If Not TFile.Exists(_settingsfilename) Then 101 | Begin 102 | SetLength(Result, 0); 103 | Exit; 104 | End; 105 | 106 | Result := TFile.ReadAllBytes(_settingsfilename); 107 | If _compressed Then 108 | Result.Decompress; 109 | End; 110 | 111 | Procedure TAEApplicationSettings.Load; 112 | Var 113 | json: TJSONObject; 114 | tb: TBytes; 115 | Begin 116 | If Not FileExists(_settingsfilename) Then 117 | Begin 118 | _loaded := True; 119 | Exit; 120 | End; 121 | 122 | Try 123 | _loading := True; 124 | tb := Self.FileBytes; 125 | 126 | Self.BeforeLoad(tb); 127 | 128 | {$IF CompilerVersion > 32} // Everything above 10.2...? 129 | json := TJSONObject(TJSONObject.ParseJSONValue(tb, 0, [TJSONObject.TJSONParseOption.IsUTF8, TJSONObject.TJSONParseOption.RaiseExc])); 130 | {$ELSE} 131 | json := TJSONObject(TJSONObject.ParseJSONValue(tb, 0, [TJSONObject.TJSONParseOption.IsUTF8])); 132 | If Not Assigned(json) Then 133 | Raise EJSONException.Create('Settings file is not a valid JSON document!'); 134 | {$ENDIF} 135 | 136 | Try 137 | Self.AsJSON := json; 138 | _loaded := True; 139 | Finally 140 | FreeAndNil(json); 141 | End; 142 | 143 | If _loaded And _settingsmigrated Then 144 | Save; 145 | Finally 146 | _loading := False; 147 | End; 148 | 149 | Self.AfterLoad; 150 | End; 151 | 152 | Class Function TAEApplicationSettings.New(Const inFileLocation: TSettingsFileLocation; Const inCompression: TSettingsFileCompresion = scAutoDetect): TAEApplicationSettings; 153 | Var 154 | compressed: Boolean; 155 | ext: String; 156 | Begin 157 | compressed := (inCompression = scCompressed) {$IFNDEF DEBUG} Or (inCompression = scAutoDetect){$ENDIF}; 158 | If compressed Then 159 | ext := '.settings' 160 | Else 161 | ext := '.json'; 162 | 163 | Result := Self.Create(TAEApplicationSettings.SettingsFileDir(inFileLocation) + ChangeFileExt(ExtractFileName(ParamStr(0)), ext)); 164 | Result.Compressed := compressed; 165 | End; 166 | 167 | Procedure TAEApplicationSettings.Save; 168 | Var 169 | json: TJSONObject; 170 | tb: TBytes; 171 | Begin 172 | json := Self.AsJSON; 173 | If Assigned(json) Then 174 | Try 175 | If Not _compressed Then 176 | {$IF CompilerVersion > 32} // Everything above 10.2...? 177 | tb := TEncoding.UTF8.GetBytes(json.Format) 178 | {$ELSE} 179 | tb := TEncoding.UTF8.GetBytes(json.ToJSON) 180 | {$ENDIF} 181 | Else 182 | Begin 183 | SetLength(tb, json.EstimatedByteSize); 184 | SetLength(tb, json.ToBytes(tb, 0)); 185 | End; 186 | 187 | Self.BeforeSave(tb); 188 | 189 | Self.FileBytes := tb; 190 | 191 | _loaded := True; 192 | _settingsmigrated := False; 193 | Finally 194 | FreeAndNil(json); 195 | End; 196 | 197 | Self.AfterSave; 198 | End; 199 | 200 | Procedure TAEApplicationSettings.SetFileBytes(Const inBytes: TBytes); 201 | Var 202 | dir: String; 203 | Begin 204 | dir := ExtractfilePath(_settingsfilename); 205 | If Not TDirectory.Exists(dir) Then 206 | TDirectory.CreateDirectory(dir); 207 | 208 | If _compressed Then 209 | inBytes.Compress; 210 | 211 | TFile.WriteAllBytes(_settingsfilename, inBytes); 212 | If Not _destroying And Not _loading Then 213 | Self.Load; 214 | End; 215 | 216 | Class Function TAEApplicationSettings.SettingsFileDir(Const inFileLocation: TSettingsFileLocation): String; 217 | Begin 218 | Case inFileLocation Of 219 | slNextToExe: 220 | Result := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))); 221 | Else 222 | Begin 223 | If inFileLocation = slAppData Then 224 | Result := IncludeTrailingPathDelimiter(TPath.GetHomePath) 225 | Else 226 | If inFileLocation = slDocuments Then 227 | Result := IncludeTrailingPathDelimiter(TPath.GetDocumentsPath); 228 | 229 | Result := IncludeTrailingPathDelimiter(Result + ChangeFileExt(ExtractFileName(ParamStr(0)), '')); 230 | End; 231 | End; 232 | End; 233 | 234 | Procedure TAEApplicationSettings.SettingsMigrated; 235 | Begin 236 | _loaded := True; 237 | _settingsmigrated := True; 238 | End; 239 | 240 | End. 241 | -------------------------------------------------------------------------------- /AE.Application/AE.Application.Engine.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Application.Engine; 10 | 11 | // 12 | // This library is being used by the following applications: 13 | // AEWOLDaemon, VStarCamDownloader 14 | // 15 | 16 | Interface 17 | 18 | Uses AE.Application.Helper, System.Classes, System.SysUtils; 19 | 20 | Type 21 | TAEApplicationThread = Class(TThread) 22 | strict private 23 | _afterwork: TProcedureOfObject; 24 | _beforework: TProcedureOfObject; 25 | _threaderror: TErrorHandler; 26 | _workcycle: TProcedureOfObject; 27 | protected 28 | Procedure Execute; Override; 29 | public 30 | Constructor Create; ReIntroduce; 31 | Property AfterWork: TProcedureOfObject Read _afterwork Write _afterwork; 32 | Property BeforeWork: TProcedureOfObject Read _beforework Write _beforework; 33 | Property ThreadError: TErrorHandler Read _threaderror Write _threaderror; 34 | Property Terminated; 35 | Property WorkCycle: TProcedureOfObject Read _workcycle Write _workcycle; 36 | End; 37 | 38 | TAEApplicationEngine = Class 39 | strict private 40 | _log: TLogProcedure; 41 | Function GetTerminated: Boolean; 42 | Function GetThreadID: Cardinal; 43 | strict protected 44 | EngineThread: TAEApplicationThread; 45 | Procedure AfterWork; Virtual; 46 | Procedure BeforeWork; Virtual; 47 | Procedure Creating; Virtual; 48 | Procedure Destroying; Virtual; 49 | Procedure HandleException(inException: Exception; inWhile: String); Virtual; 50 | Procedure Log(inString: String); Virtual; 51 | Procedure ThreadError(inException: Exception); Virtual; 52 | Procedure WorkCycle; Virtual; 53 | public 54 | Constructor Create(inLogProcedure: TLogProcedure); ReIntroduce; Virtual; 55 | Destructor Destroy; Override; 56 | Procedure Start; 57 | Procedure Terminate; 58 | Function EndedExecution(inTimeout: Cardinal = 50): Boolean; 59 | Function GracefullyEnd(inTimeout: Cardinal): Boolean; Virtual; 60 | Property Terminated: Boolean Read GetTerminated; 61 | Property ThreadID: Cardinal Read GetThreadID; 62 | End; 63 | 64 | Implementation 65 | 66 | {$IFDEF MSWINDOWS} 67 | Uses WinApi.Windows; 68 | {$ENDIF} 69 | 70 | // 71 | // TAEApplicationThread 72 | // 73 | 74 | Constructor TAEApplicationThread.Create; 75 | Begin 76 | inherited Create(True); 77 | 78 | Self.FreeOnTerminate := False; 79 | _afterwork := nil; 80 | _beforework := nil; 81 | _workcycle := nil; 82 | _threaderror := nil; 83 | End; 84 | 85 | Procedure TAEApplicationThread.Execute; 86 | Begin 87 | If Assigned(_beforework) Then 88 | _beforework; 89 | 90 | Try 91 | If Terminated Then 92 | Exit; 93 | 94 | Repeat 95 | Try 96 | If Assigned(_workcycle) Then 97 | _workcycle; 98 | 99 | Sleep(5); 100 | Except 101 | On E: Exception Do 102 | If Assigned(_threaderror) Then 103 | _threaderror(E) 104 | Else 105 | Raise; 106 | End; 107 | Until Terminated; 108 | Finally 109 | If Assigned(_afterwork) Then 110 | _afterwork; 111 | End; 112 | End; 113 | 114 | // 115 | // TAEApplicationEngine 116 | // 117 | 118 | Procedure TAEApplicationEngine.AfterWork; 119 | Begin 120 | {$IFDEF DEBUG} 121 | Log('Terminate signal received.'); 122 | {$ENDIF} 123 | end; 124 | 125 | Procedure TAEApplicationEngine.BeforeWork; 126 | Begin 127 | {$IFDEF DEBUG} 128 | Log('Sarted with ID: ' + EngineThread.ThreadID.ToString {$IFDEF MSWINDOWS} + ', Handle: ' + EngineThread.Handle.ToString {$ENDIF}); 129 | {$ENDIF} 130 | End; 131 | 132 | Constructor TAEApplicationEngine.Create(inLogProcedure: TLogProcedure); 133 | Begin 134 | inherited Create; 135 | 136 | If Not Assigned(inLogProcedure) Then 137 | Raise EArgumentException.Create('LogProcedure can not be empty!'); 138 | 139 | _log := inLogProcedure; 140 | Self.EngineThread := TAEApplicationThread.Create; 141 | Self.EngineThread.AfterWork := Self.AfterWork; 142 | Self.EngineThread.BeforeWork := Self.BeforeWork; 143 | Self.EngineThread.WorkCycle := Self.WorkCycle; 144 | Self.EngineThread.ThreadError := Self.ThreadError; 145 | 146 | {$IFDEF DEBUG} 147 | TThread.NameThreadForDebugging(Self.ClassName, EngineThread.ThreadID); 148 | {$ENDIF} 149 | 150 | Self.Creating; 151 | End; 152 | 153 | Procedure TAEApplicationEngine.Creating; 154 | Begin 155 | // Dummy 156 | End; 157 | 158 | Destructor TAEApplicationEngine.Destroy; 159 | Begin 160 | If Assigned(EngineThread) Then 161 | Begin 162 | Self.GracefullyEnd(0); 163 | FreeAndNil(EngineThread); 164 | End; 165 | 166 | _log := nil; 167 | Self.Destroying; 168 | 169 | inherited; 170 | End; 171 | 172 | Procedure TAEApplicationEngine.Destroying; 173 | Begin 174 | // Dummy 175 | End; 176 | 177 | Function TAEApplicationEngine.EndedExecution(inTimeout: Cardinal): Boolean; 178 | Begin 179 | {$IFDEF MSWINDOWS} 180 | Result := WaitForSingleObject(Self.EngineThread.Handle, inTimeout) 181 | = WAIT_OBJECT_0; 182 | {$ELSE} 183 | Result := Self.EngineThread.Finished; 184 | {$ENDIF} 185 | End; 186 | 187 | Function TAEApplicationEngine.GetTerminated: Boolean; 188 | Begin 189 | Result := Self.EngineThread.Terminated; 190 | End; 191 | 192 | Function TAEApplicationEngine.GetThreadID: Cardinal; 193 | Begin 194 | Result := EngineThread.ThreadID; 195 | End; 196 | 197 | Function TAEApplicationEngine.GracefullyEnd(inTimeout: Cardinal): Boolean; 198 | Var 199 | totalwaited: Cardinal; 200 | Begin 201 | If Not Self.EngineThread.Terminated Then 202 | Self.EngineThread.Terminate; 203 | 204 | If Self.EngineThread.Suspended Then 205 | Self.EngineThread.Start; 206 | 207 | If inTimeout = 0 Then 208 | Begin 209 | Self.EngineThread.WaitFor; 210 | Result := True; 211 | End 212 | Else 213 | Begin 214 | totalwaited := 0; 215 | Result := False; 216 | 217 | Repeat 218 | If Self.EndedExecution(POLLINTERVAL) Then 219 | Result := True 220 | Else 221 | totalwaited := totalwaited + POLLINTERVAL; 222 | Until (Result) Or (totalwaited >= inTimeout); 223 | 224 | If Not Result Then 225 | {$IFDEF MSWINDOWS} 226 | TerminateThread(Self.EngineThread.Handle, 0); 227 | {$ENDIF} 228 | End; 229 | End; 230 | 231 | Procedure TAEApplicationEngine.HandleException(inException: Exception; 232 | inWhile: String); 233 | Var 234 | errormsg: String; 235 | Begin 236 | If inWhile = '' Then 237 | errormsg := inException.ClassName + ' was raised with the message: ' + 238 | inException.Message 239 | Else 240 | errormsg := inException.ClassName + ' was raised ' + inWhile + 241 | ' with the message: ' + inException.Message; 242 | Log(errormsg); 243 | End; 244 | 245 | Procedure TAEApplicationEngine.Log(inString: String); 246 | Begin 247 | If Assigned(_log) Then 248 | _log('[' + Self.ClassName + '] ' + inString) 249 | End; 250 | 251 | Procedure TAEApplicationEngine.Start; 252 | Begin 253 | Self.EngineThread.Start; 254 | End; 255 | 256 | Procedure TAEApplicationEngine.Terminate; 257 | Begin 258 | Self.EngineThread.Terminate; 259 | End; 260 | 261 | Procedure TAEApplicationEngine.ThreadError(inException: Exception); 262 | Begin 263 | If Not(inException Is EAbort) Then 264 | Self.HandleException(inException, 'during ' + Self.ClassName + 265 | ' exectution'); 266 | End; 267 | 268 | Procedure TAEApplicationEngine.WorkCycle; 269 | Begin 270 | {$IFDEF MSWINDOWS} 271 | CustomMessagePump; 272 | {$ENDIF} 273 | End; 274 | 275 | End. 276 | -------------------------------------------------------------------------------- /AE.Misc/MNB.ExchangeRate.SoapService.pas: -------------------------------------------------------------------------------- 1 | // ************************************************************************ // 2 | // The types declared in this file were generated from data read from the 3 | // WSDL File described below: 4 | // WSDL : http://www.mnb.hu/arfolyamok.asmx?wsdl 5 | // >Import : http://www.mnb.hu/arfolyamok.asmx?wsdl=wsdl0 6 | // >Import : http://www.mnb.hu/arfolyamok.asmx?wsdl=wsdl0>0 7 | // >Import : http://www.mnb.hu/arfolyamok.asmx?xsd=xsd1 8 | // >Import : http://www.mnb.hu/arfolyamok.asmx?xsd=xsd0 9 | // Encoding : utf-8 10 | // Version : 1.0 11 | // (2023. 02. 14. 12:00:12 - - $Rev: 108085 $) 12 | // ************************************************************************ // 13 | 14 | unit MNB.ExchangeRate.SoapService; 15 | 16 | interface 17 | 18 | uses Soap.InvokeRegistry, Soap.SOAPHTTPClient, System.Types, Soap.XSBuiltIns; 19 | 20 | const 21 | IS_OPTN = $0001; 22 | IS_NLBL = $0004; 23 | 24 | 25 | type 26 | 27 | // ************************************************************************ // 28 | // The following types, referred to in the WSDL document are not being represented 29 | // in this file. They are either aliases[@] of other types represented or were referred 30 | // to but never[!] declared in the document. The types from the latter category 31 | // typically map to predefined/known XML or Embarcadero types; however, they could also 32 | // indicate incorrect WSDL documents that failed to declare or import a schema type. 33 | // ************************************************************************ // 34 | // !:string - "http://www.w3.org/2001/XMLSchema"[Gbl] 35 | 36 | string_ = class; { "http://schemas.microsoft.com/2003/10/Serialization/"[Flt][Alias] } 37 | 38 | 39 | 40 | // ************************************************************************ // 41 | // XML : string, alias 42 | // Namespace : http://schemas.microsoft.com/2003/10/Serialization/ 43 | // Serializtn: [xoSimpleTypeWrapper] 44 | // Info : Fault 45 | // ************************************************************************ // 46 | string_ = class(ERemotableException) 47 | private 48 | FValue: string; 49 | published 50 | property Value: string read FValue write FValue; 51 | end; 52 | 53 | 54 | // ************************************************************************ // 55 | // Namespace : http://www.mnb.hu/webservices/ 56 | // soapAction: http://www.mnb.hu/webservices/MNBArfolyamServiceSoap/%operationName% 57 | // transport : http://schemas.xmlsoap.org/soap/http 58 | // style : document 59 | // use : literal 60 | // binding : CustomBinding_MNBArfolyamServiceSoap 61 | // service : MNBArfolyamServiceSoapImpl 62 | // port : CustomBinding_MNBArfolyamServiceSoap 63 | // URL : http://www.mnb.hu/arfolyamok.asmx 64 | // ************************************************************************ // 65 | MNBArfolyamServiceSoap = interface(IInvokable) 66 | ['{059D23E9-C567-5AD4-94C3-3A090B1CA894}'] 67 | function GetCurrencies: string; stdcall; 68 | function GetCurrencyUnits(const currencyNames: string): string; stdcall; 69 | function GetCurrentExchangeRates: string; stdcall; 70 | function GetDateInterval: string; stdcall; 71 | function GetExchangeRates(const startDate: string; const endDate: string; const currencyNames: string): string; stdcall; 72 | function GetInfo: string; stdcall; 73 | end; 74 | 75 | function GetMNBArfolyamServiceSoap(UseWSDL: Boolean=System.False; Addr: string=''; HTTPRIO: THTTPRIO = nil): MNBArfolyamServiceSoap; 76 | 77 | 78 | implementation 79 | uses System.SysUtils; 80 | 81 | function GetMNBArfolyamServiceSoap(UseWSDL: Boolean; Addr: string; HTTPRIO: THTTPRIO): MNBArfolyamServiceSoap; 82 | const 83 | defWSDL = 'http://www.mnb.hu/arfolyamok.asmx?wsdl'; 84 | defURL = 'http://www.mnb.hu/arfolyamok.asmx'; 85 | defSvc = 'MNBArfolyamServiceSoapImpl'; 86 | defPrt = 'CustomBinding_MNBArfolyamServiceSoap'; 87 | var 88 | RIO: THTTPRIO; 89 | begin 90 | Result := nil; 91 | if (Addr = '') then 92 | begin 93 | if UseWSDL then 94 | Addr := defWSDL 95 | else 96 | Addr := defURL; 97 | end; 98 | if HTTPRIO = nil then 99 | RIO := THTTPRIO.Create(nil) 100 | else 101 | RIO := HTTPRIO; 102 | try 103 | Result := (RIO as MNBArfolyamServiceSoap); 104 | if UseWSDL then 105 | begin 106 | RIO.WSDLLocation := Addr; 107 | RIO.Service := defSvc; 108 | RIO.Port := defPrt; 109 | end else 110 | RIO.URL := Addr; 111 | finally 112 | if (Result = nil) and (HTTPRIO = nil) then 113 | RIO.Free; 114 | end; 115 | end; 116 | 117 | 118 | initialization 119 | { MNBArfolyamServiceSoap } 120 | InvRegistry.RegisterInterface(TypeInfo(MNBArfolyamServiceSoap), 'http://www.mnb.hu/webservices/', 'utf-8'); 121 | InvRegistry.RegisterDefaultSOAPAction(TypeInfo(MNBArfolyamServiceSoap), 'http://www.mnb.hu/webservices/MNBArfolyamServiceSoap/%operationName%'); 122 | InvRegistry.RegisterInvokeOptions(TypeInfo(MNBArfolyamServiceSoap), ioDocument); 123 | { MNBArfolyamServiceSoap.GetCurrencies } 124 | InvRegistry.RegisterMethodInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrencies', '', 125 | '[ReturnName="GetCurrenciesResult"]', IS_OPTN or IS_NLBL); 126 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrencies', 'GetCurrenciesResult', '', 127 | '', IS_NLBL); 128 | { MNBArfolyamServiceSoap.GetCurrencyUnits } 129 | InvRegistry.RegisterMethodInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrencyUnits', '', 130 | '[ReturnName="GetCurrencyUnitsResult"]', IS_OPTN or IS_NLBL); 131 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrencyUnits', 'currencyNames', '', 132 | '', IS_NLBL); 133 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrencyUnits', 'GetCurrencyUnitsResult', '', 134 | '', IS_NLBL); 135 | { MNBArfolyamServiceSoap.GetCurrentExchangeRates } 136 | InvRegistry.RegisterMethodInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrentExchangeRates', '', 137 | '[ReturnName="GetCurrentExchangeRatesResult"]', IS_OPTN or IS_NLBL); 138 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetCurrentExchangeRates', 'GetCurrentExchangeRatesResult', '', 139 | '', IS_NLBL); 140 | { MNBArfolyamServiceSoap.GetDateInterval } 141 | InvRegistry.RegisterMethodInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetDateInterval', '', 142 | '[ReturnName="GetDateIntervalResult"]', IS_OPTN or IS_NLBL); 143 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetDateInterval', 'GetDateIntervalResult', '', 144 | '', IS_NLBL); 145 | { MNBArfolyamServiceSoap.GetExchangeRates } 146 | InvRegistry.RegisterMethodInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetExchangeRates', '', 147 | '[ReturnName="GetExchangeRatesResult"]', IS_OPTN or IS_NLBL); 148 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetExchangeRates', 'startDate', '', 149 | '', IS_NLBL); 150 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetExchangeRates', 'endDate', '', 151 | '', IS_NLBL); 152 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetExchangeRates', 'currencyNames', '', 153 | '', IS_NLBL); 154 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetExchangeRates', 'GetExchangeRatesResult', '', 155 | '', IS_NLBL); 156 | { MNBArfolyamServiceSoap.GetInfo } 157 | InvRegistry.RegisterMethodInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetInfo', '', 158 | '[ReturnName="GetInfoResult"]', IS_OPTN or IS_NLBL); 159 | InvRegistry.RegisterParamInfo(TypeInfo(MNBArfolyamServiceSoap), 'GetInfo', 'GetInfoResult', '', 160 | '', IS_NLBL); 161 | RemClassRegistry.RegisterXSClass(string_, 'http://schemas.microsoft.com/2003/10/Serialization/', 'string_', 'string'); 162 | RemClassRegistry.RegisterSerializeOptions(string_, [xoSimpleTypeWrapper]); 163 | 164 | end. -------------------------------------------------------------------------------- /AE.Comp/AE.Comp.KeepMeAwake.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2023 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.KeepMeAwake; 10 | 11 | Interface 12 | 13 | Uses System.Classes, Vcl.ExtCtrls, WinApi.Windows, System.SysUtils; 14 | 15 | Type 16 | TAEKeepMeAwakeMode = ( kamNone, kamMouseMove, kamMouseWheel, kamKeyPress, kamMouseClick ); 17 | 18 | TAEKeepMeAwakeModeChangeEvent = Procedure(Sender: TObject; Const inNewMode: TAEKeepMeAwakeMode) Of Object; 19 | TAEKeepMeAwakeErrorEvent = Procedure(Sender: TObject; Const inException: Exception; Var outDeactivate: Boolean) Of Object; 20 | 21 | TAEKeepMeAwake = Class(TComponent) 22 | strict private 23 | _interval: Integer; 24 | _onerror: TAEKeepMeAwakeErrorEvent; 25 | _onmodechange: TAEKeepMeAwakeModeChangeEvent; 26 | _prevmode: TAEKeepMeAwakeMode; 27 | _timer: TTimer; 28 | Procedure InternalClickMouse; 29 | Procedure InternalMoveMouse; 30 | Procedure InternalPressKey; 31 | Procedure InternalScrollMouseWheel; 32 | Procedure SendInputs(inInputs: Array Of TInput); 33 | Procedure SetActive(Const inActive: Boolean); 34 | Procedure TimerTimer(Sender: TObject); 35 | Procedure ZeroInputs(Const inInputs: Array Of TInput); 36 | Function GetActive: Boolean; 37 | Function InternalDetectKeepMeAwakeMethod(Const inInitialIdleTime: Integer): Boolean; 38 | Function SecondsIdle: Integer; 39 | public 40 | Constructor Create(Owner: TComponent); Override; 41 | published 42 | Property Active: Boolean Read GetActive Write SetActive; 43 | Property Interval: Integer Read _interval Write _interval; 44 | Property OnError: TAEKeepMeAwakeErrorEvent Read _onerror Write _onerror; 45 | Property OnKeepMeAwakeModeChanged: TAEKeepMeAwakeModeChangeEvent Read _onmodechange Write _onmodechange; 46 | End; 47 | 48 | Implementation 49 | 50 | Constructor TAEKeepMeAwake.Create(Owner: TComponent); 51 | Begin 52 | inherited; 53 | 54 | // Default interval: 4 minutes (240 seconds) 55 | _interval := 240; 56 | 57 | _onerror := nil; 58 | _onmodechange := nil; 59 | 60 | _prevmode := kamNone; 61 | 62 | _timer := TTimer.Create(Self); 63 | _timer.Interval := 1000; 64 | _timer.Enabled := False; 65 | _timer.OnTimer := TimerTimer; 66 | End; 67 | 68 | Function TAEKeepMeAwake.GetActive: Boolean; 69 | Begin 70 | Result := _timer.Enabled; 71 | End; 72 | 73 | Procedure TAEKeepMeAwake.InternalClickMouse; 74 | Var 75 | inputs: Array[0..1] Of TInput; 76 | Begin 77 | // Absolutely invasive method: simulate a middle click with the mouse. This can cause the cursor to switch to scroll mode 78 | // if it's hovering over a multi-line text input field 79 | 80 | ZeroInputs(inputs); 81 | 82 | // Define first input: press middle button 83 | inputs[0].Itype := INPUT_MOUSE; 84 | inputs[0].mi.dwFlags := MOUSEEVENTF_MIDDLEDOWN; 85 | 86 | // Define second input: release middle button 87 | inputs[1].Itype := INPUT_MOUSE; 88 | inputs[1].mi.dwFlags := MOUSEEVENTF_MIDDLEUP; 89 | 90 | SendInputs(inputs); 91 | End; 92 | 93 | Function TAEKeepMeAwake.InternalDetectKeepMeAwakeMethod(Const inInitialIdleTime: Integer): Boolean; 94 | Var 95 | mode: TAEKeepMeAwakeMode; 96 | Begin 97 | Result := True; 98 | 99 | mode := kamMouseMove; 100 | InternalMoveMouse; 101 | 102 | If SecondsIdle >= inInitialIdleTime Then 103 | Begin 104 | mode := kamMouseWheel; 105 | InternalScrollMouseWheel; 106 | 107 | If SecondsIdle >= inInitialIdleTime Then 108 | Begin 109 | mode := kamKeyPress; 110 | InternalPressKey; 111 | 112 | If SecondsIdle >= inInitialIdleTime Then 113 | Begin 114 | mode := kamMouseClick; 115 | InternalClickMouse; 116 | 117 | If SecondsIdle >= inInitialIdleTime Then 118 | Begin 119 | mode := kamNone; 120 | 121 | Result := False; 122 | End; 123 | End; 124 | End; 125 | End; 126 | 127 | If mode <> _prevmode Then 128 | Begin 129 | If Assigned(_onmodechange) Then 130 | _onmodechange(Self, mode); 131 | 132 | _prevmode := mode; 133 | End; 134 | End; 135 | 136 | Procedure TAEKeepMeAwake.InternalMoveMouse; 137 | Var 138 | inputs: Array[0..0] Of TInput; 139 | Begin 140 | // Non-invasive way to reset timer: simulate a 0-pixel movement of the mouse cursor 141 | 142 | ZeroInputs(inputs); 143 | 144 | inputs[0].Itype := INPUT_MOUSE; 145 | 146 | inputs[0].mi.dwFlags := MOUSEEVENTF_MOVE; 147 | inputs[0].mi.dx := 0; 148 | inputs[0].mi.dy := 0; 149 | inputs[0].mi.mouseData := 0; 150 | inputs[0].mi.time := 0; 151 | inputs[0].mi.dwExtraInfo := 0; 152 | 153 | SendInputs(inputs); 154 | End; 155 | 156 | Procedure TAEKeepMeAwake.InternalPressKey; 157 | Var 158 | inputs: Array[0..1] Of TInput; 159 | Begin 160 | // Absolutely invasive method: simulate a quick press and release of the Scroll Lock key. 161 | // Depending on the active application this can have unwanted results. 162 | 163 | ZeroInputs(inputs); 164 | 165 | // Define first input: press scroll lock 166 | inputs[0].Itype := INPUT_KEYBOARD; 167 | 168 | inputs[0].ki.wVk := VK_SCROLL; 169 | inputs[0].ki.wScan := MapVirtualKeyEx(inputs[0].ki.wVk, 0, 0); 170 | inputs[0].ki.dwFlags := 0; 171 | 172 | // Define second input: release scroll lock 173 | inputs[1].Itype := INPUT_KEYBOARD; 174 | 175 | inputs[1].ki.wVk := VK_SCROLL; 176 | inputs[1].ki.wScan := MapVirtualKeyEx(inputs[1].ki.wVk, 0, 0); 177 | inputs[1].ki.dwFlags := KEYEVENTF_KEYUP; 178 | 179 | SendInputs(inputs); 180 | End; 181 | 182 | Procedure TAEKeepMeAwake.InternalScrollMouseWheel; 183 | Var 184 | inputs: Array[0..0] Of TInput; 185 | Begin 186 | // Non-invasive way to reset timer: simulate a 0-pixel movement of the mouse wheel 187 | 188 | ZeroInputs(inputs); 189 | 190 | inputs[0].Itype := INPUT_MOUSE; 191 | 192 | inputs[0].mi.dwFlags := MOUSEEVENTF_WHEEL; 193 | inputs[0].mi.mouseData := 0; 194 | inputs[0].mi.time := 0; 195 | inputs[0].mi.dwExtraInfo := 0; 196 | 197 | SendInputs(inputs); 198 | End; 199 | 200 | Function TAEKeepMeAwake.SecondsIdle: Integer; 201 | Var 202 | lastinput: TLastInputInfo; 203 | Begin 204 | lastinput.cbSize := SizeOf(TLastInputInfo); 205 | 206 | If Not GetLastInputInfo(lastinput) Then 207 | RaiseLastOSError; 208 | 209 | Result := (GetTickCount - lastinput.dwTime) Div 1000; 210 | End; 211 | 212 | Procedure TAEKeepMeAwake.SendInputs(inInputs: Array Of TInput); 213 | Var 214 | len: Cardinal; 215 | Begin 216 | len := Length(inInputs); 217 | 218 | If SendInput(Length(inInputs), inInputs[0], SizeOf(TInput)) <> len Then 219 | RaiseLastOSError; 220 | End; 221 | 222 | Procedure TAEKeepMeAwake.SetActive(Const inActive: Boolean); 223 | Begin 224 | _timer.Enabled := inActive; 225 | End; 226 | 227 | Procedure TAEKeepMeAwake.TimerTimer(Sender: TObject); 228 | Var 229 | idle: Integer; 230 | deactivate: Boolean; 231 | Begin 232 | Try 233 | idle := SecondsIdle; 234 | 235 | If idle < _interval Then 236 | Exit; 237 | 238 | Case _prevmode Of 239 | kamNone: 240 | If Not InternalDetectKeepMeAwakeMethod(idle) Then 241 | Self.Active := False; 242 | kamMouseMove: 243 | InternalMoveMouse; 244 | kamMouseWheel: 245 | InternalScrollMouseWheel; 246 | kamKeyPress: 247 | InternalPressKey; 248 | kamMouseClick: 249 | InternalClickMouse; 250 | Else 251 | Raise ENotImplemented.Create('Keep me awake method isn''t implemented yet!'); 252 | End; 253 | 254 | If (SecondsIdle >= idle) And (_prevmode <> kamNone) Then 255 | Begin 256 | _prevmode := kamNone; 257 | 258 | If Assigned(_onmodechange) Then 259 | _onmodechange(Self, _prevmode); 260 | End; 261 | Except 262 | On E:Exception Do 263 | If Assigned(_onerror) Then 264 | Begin 265 | deactivate := True; 266 | 267 | _onerror(Self, E, deactivate); 268 | 269 | _timer.Enabled := Not deactivate; 270 | End 271 | Else 272 | Begin 273 | _timer.Enabled := False; 274 | 275 | Raise; 276 | End; 277 | End; 278 | End; 279 | 280 | Procedure TAEKeepMeAwake.ZeroInputs(Const inInputs: Array Of TInput); 281 | Var 282 | a: Integer; 283 | Begin 284 | For a := Low(inInputs) To High(inInputs) Do 285 | ZeroMemory(@inInputs[a], SizeOf(TInput)); 286 | End; 287 | 288 | End. 289 | -------------------------------------------------------------------------------- /AE.Misc/AE.DDEManager.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.DDEManager; 10 | 11 | Interface 12 | 13 | Uses WinAPI.Messages, WinAPI.Windows, System.Generics.Collections, System.SysUtils; 14 | 15 | Type 16 | TAEDDEManager = Class 17 | strict private 18 | _ansimode: Boolean; 19 | _discoverytimeout: Cardinal; 20 | _servers: TObjectDictionary>; 21 | _service: String; 22 | _topic: String; 23 | Procedure CheckPID(Const inPID: Cardinal); 24 | Procedure DiscoveryHandler(Var inMessage: TMessage); 25 | Procedure InternalExecuteCommand(Const inCommand: String; Const inWindowHandle: HWND; Const inTimeOutInMs: Cardinal = 5000); 26 | Procedure Purge; 27 | Function GetDDEServerPIDs: TArray; 28 | Function GetDDEServerWindows(Const inPID: Cardinal): TArray; 29 | Function GlobalLockString(Const inValue: String; Const inFlags: Cardinal): THandle; 30 | public 31 | Constructor Create(Const inService, inTopic: String; Const inANSIMode: Boolean = False; Const inDiscoveryTimeout: Cardinal = 1); ReIntroduce; 32 | Destructor Destroy; Override; 33 | Procedure ExecuteCommand(Const inCommand: String; Const inPID: Cardinal; Const inTimeOutInMs: Cardinal = 5000); 34 | Procedure RefreshServers; 35 | Function ServerFound(Const inPID: Cardinal): Boolean; 36 | Property DDEServerPIDs: TArray Read GetDDEServerPIDs; 37 | Property DDEServerWindows[Const inPID: Cardinal]: TArray Read GetDDEServerWindows; 38 | End; 39 | 40 | EAEDDEManagerException = Class(Exception); 41 | 42 | Function UnpackDDElParam(msg: UINT; lParam: LPARAM; puiLo, puiHi: PUINT_PTR): BOOL; StdCall; External user32; 43 | Function FreeDDElParam(msg: UINT; lParam: LPARAM): BOOL; StdCall; External user32; 44 | 45 | Implementation 46 | 47 | Uses System.Classes; 48 | 49 | Procedure TAEDDEManager.CheckPID(Const inPID: Cardinal); 50 | Begin 51 | If Not _servers.ContainsKey(inPID) Then 52 | Raise EAEDDEManagerException.Create('Process with PID ' + inPID.ToString + ' was not detected as a valid DDE target for service ' + _service + ', topic ' + _topic + '!'); 53 | End; 54 | 55 | Constructor TAEDDEManager.Create(Const inService, inTopic: String; Const inANSIMode: Boolean = False; Const inDiscoveryTimeout: Cardinal = 1); 56 | Begin 57 | inherited Create; 58 | 59 | _ansimode := inANSIMode; 60 | _discoverytimeout := inDiscoveryTimeout; 61 | _servers := TObjectDictionary>.Create([doOwnsValues]); 62 | _service := inService; 63 | _topic := inTopic; 64 | 65 | Self.RefreshServers; 66 | End; 67 | 68 | Destructor TAEDDEManager.Destroy; 69 | Begin 70 | FreeAndNil(_servers); 71 | 72 | inherited; 73 | End; 74 | 75 | Procedure TAEDDEManager.DiscoveryHandler(Var inMessage: TMessage); 76 | Var 77 | whandle: HWND; 78 | pid: Cardinal; 79 | Begin 80 | If inMessage.Msg <> WM_DDE_ACK Then 81 | Exit; 82 | 83 | whandle := inMessage.WParam; 84 | GetWindowThreadProcessId(whandle, pid); 85 | 86 | If Not _servers.ContainsKey(pid) Then 87 | _servers.Add(pid, TList.Create); 88 | 89 | If Not _servers[pid].Contains(whandle) Then 90 | _servers[pid].Add(whandle); 91 | End; 92 | 93 | Procedure TAEDDEManager.ExecuteCommand(Const inCommand: String; Const inPID: Cardinal; Const inTimeOutInMs: Cardinal = 5000); 94 | Var 95 | hw: HWND; 96 | Begin 97 | CheckPID(inPID); 98 | 99 | Self.Purge; 100 | 101 | If Not _servers.ContainsKey(inPID) Then 102 | Raise EAEDDEManagerException.Create('Process with PID ' + inPID.ToString + ' has gone away as a valid DDE target for service ' + _service + ', topic ' + _topic + '!'); 103 | 104 | For hw In _servers[inPID] Do 105 | InternalExecuteCommand(inCommand, hw, inTimeOutInMs); 106 | End; 107 | 108 | Function TAEDDEManager.GetDDEServerPIDs: TArray; 109 | Begin 110 | Self.Purge; 111 | 112 | Result := _servers.Keys.ToArray; 113 | End; 114 | 115 | Function TAEDDEManager.GetDDEServerWindows(Const inPID: Cardinal): TArray; 116 | Begin 117 | CheckPID(inPID); 118 | 119 | Result := _servers[inPID].ToArray; 120 | End; 121 | 122 | Function TAEDDEManager.GlobalLockString(Const inValue: String; Const inFlags: Cardinal): THandle; 123 | Var 124 | size: Integer; 125 | p: Pointer; 126 | Begin 127 | If _ansimode Then 128 | size := Length(inValue) 129 | Else 130 | size := Length(inValue) * SizeOf(Char); 131 | 132 | Result := GlobalAlloc(GMEM_ZEROINIT Or inFlags, size + 1); 133 | 134 | Try 135 | p := GlobalLock(Result); 136 | 137 | If _ansimode Then 138 | Move(PAnsiChar(AnsiString(inValue))^, p^, size) 139 | Else 140 | Move(PChar(inValue)^, p^, size); 141 | Except 142 | GlobalFree(Result); 143 | Raise; 144 | End; 145 | End; 146 | 147 | Procedure TAEDDEManager.InternalExecuteCommand(Const inCommand: String; Const inWindowHandle: HWND; Const inTimeOutInMs: Cardinal = 5000); 148 | Var 149 | serviceatom, topicatom: Word; 150 | commandhandle: THandle; 151 | msg: TMsg; 152 | wait: Cardinal; 153 | pLo, pHi: UIntPtr; 154 | exechwnd: HWND; 155 | Begin 156 | commandhandle := GlobalLockString(inCommand, GMEM_DDESHARE); 157 | 158 | exechwnd := AllocateHwnd(nil); 159 | Try 160 | If _ansimode then 161 | serviceatom := GlobalAddAtomA(PAnsiChar(AnsiString(_service))) 162 | Else 163 | serviceatom := GlobalAddAtom(PChar(_service)); 164 | 165 | If serviceatom = 0 Then 166 | RaiseLastOSError; 167 | 168 | Try 169 | If _ansimode Then 170 | topicatom := GlobalAddAtomA(PAnsiChar(AnsiString(_topic))) 171 | Else 172 | topicatom := GlobalAddAtom(PChar(_topic)); 173 | 174 | If topicatom = 0 Then 175 | RaiseLastOSError; 176 | 177 | Try 178 | SendMessage(inWindowHandle, WM_DDE_INITIATE, exechwnd, Makelong(serviceatom, topicatom)); 179 | Finally 180 | GlobalDeleteAtom(topicatom); 181 | End; 182 | Finally 183 | GlobalDeleteAtom(serviceatom); 184 | End; 185 | 186 | PostMessage(inWindowHandle, WM_DDE_EXECUTE, exechwnd, commandhandle); 187 | 188 | wait := 0; 189 | Repeat 190 | If PeekMessage(msg, exechwnd, 0, 0, PM_REMOVE) Then 191 | Begin 192 | If msg.message = WM_DDE_ACK Then 193 | Begin 194 | If UnpackDDElParam(msg.Message, msg.lParam, @pLo, @pHi) Then 195 | Begin 196 | GlobalUnlock(pHi); 197 | GlobalFree(pHi); 198 | FreeDDElParam(msg.Message, msg.lParam); 199 | 200 | PostMessage(msg.wParam, WM_DDE_TERMINATE, exechwnd, 0); 201 | End; 202 | 203 | Exit; 204 | End; 205 | 206 | TranslateMessage(msg); 207 | DispatchMessage(msg); 208 | End; 209 | 210 | Sleep(200); 211 | Inc(wait, 200); 212 | Until wait >= inTimeOutInMs; 213 | 214 | // Request timed out, need to free up our resource 215 | GlobalFree(commandhandle); 216 | Raise EAEDDEManagerException.Create('Executing DDE command against process timed out!'); 217 | 218 | Finally 219 | DeallocateHWnd(exechwnd); 220 | End; 221 | End; 222 | 223 | Procedure TAEDDEManager.Purge; 224 | Var 225 | pid: Cardinal; 226 | hw: HWND; 227 | Begin 228 | // Throw out all DDE servers where the DDE window is already closed 229 | For pid In _servers.Keys.ToArray Do 230 | Begin 231 | For hw In _servers[pid].ToArray Do 232 | If Not IsWindow(hw) Then 233 | _servers[pid].Remove(hw); 234 | 235 | If _servers[pid].Count = 0 Then 236 | _servers.Remove(pid); 237 | End; 238 | End; 239 | 240 | Procedure TAEDDEManager.RefreshServers; 241 | Var 242 | serviceatom, topicatom: Word; 243 | msg: TMsg; 244 | res: DWord; 245 | discoverer: HWND; 246 | Begin 247 | _servers.Clear; 248 | 249 | discoverer := AllocateHWnd(DiscoveryHandler); 250 | Try 251 | If _ansimode Then 252 | serviceatom := GlobalAddAtomA(PAnsiChar(AnsiString(_service))) 253 | Else 254 | serviceatom := GlobalAddAtom(PChar(_service)); 255 | 256 | If serviceatom = 0 Then 257 | RaiseLastOSError; 258 | 259 | Try 260 | If _ansimode Then 261 | topicatom := GlobalAddAtomA(PAnsiChar(AnsiString(_topic))) 262 | Else 263 | topicatom := GlobalAddAtom(PChar(_topic)); 264 | 265 | If topicatom = 0 Then 266 | RaiseLastOSError; 267 | 268 | Try 269 | SendMessageTimeout(HWND_BROADCAST, WM_DDE_INITIATE, discoverer, Makelong(serviceatom, topicatom), SMTO_BLOCK, _discoverytimeout, @res); 270 | 271 | While PeekMessage(msg, discoverer, 0, 0, PM_REMOVE) Do 272 | Begin 273 | TranslateMessage(msg); 274 | DispatchMessage(msg); 275 | End; 276 | Finally 277 | GlobalDeleteAtom(topicatom); 278 | End; 279 | Finally 280 | GlobalDeleteAtom(serviceatom); 281 | End; 282 | Finally 283 | DeallocateHWnd(discoverer); 284 | End; 285 | End; 286 | 287 | Function TAEDDEManager.ServerFound(Const inPID: Cardinal): Boolean; 288 | Begin 289 | Result := _servers.ContainsKey(inPID); 290 | End; 291 | 292 | End. 293 | -------------------------------------------------------------------------------- /AE.Comp/AE.Comp.TagEditor.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2025 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.TagEditor; 10 | 11 | Interface 12 | 13 | Uses Vcl.ExtCtrls, Vcl.Forms, System.Classes, Vcl.Buttons, WinApi.Messages, Vcl.Controls; 14 | 15 | Const 16 | WM_REMOVEBTN = WM_USER + 199; 17 | 18 | Type 19 | TTagRemovedEvent = Procedure(Sender: TObject; Const inTag: String) Of Object; 20 | 21 | TTagComponent = Class(TCustomPanel) 22 | strict private 23 | _drawactive: Boolean; 24 | Procedure CMMOUSEENTER(Var inMessage: TMessage); Message CM_MOUSEENTER; 25 | Procedure CMMOUSELEAVE(Var inMessage: TMessage); Message CM_MOUSELEAVE; 26 | protected 27 | Procedure Paint; Override; 28 | public 29 | Constructor Create(AOwner: TComponent); Override; 30 | End; 31 | 32 | TAETagEditor = Class(TCustomPanel) 33 | strict private 34 | _selectedtags: TStringList; 35 | _scrollbox: TScrollBox; 36 | _ontagremoved: TTagRemovedEvent; 37 | _tagwidth: Integer; 38 | Procedure TagClick(Sender: TObject); 39 | Procedure SelectedTagsChanged(Sender: TObject); 40 | Procedure SetSelectedTags(Const inSelectedTags: TStringList); 41 | Procedure SetTagWidth(Const inTagWidth: Integer); 42 | Procedure WMREMOVEBTN(Var inMessage: TMessage); Message WM_REMOVEBTN; 43 | strict protected 44 | Procedure AddTagButton(Const inTag: String); 45 | Procedure TagRemoved(Const inTag: String); Virtual; 46 | Procedure RemoveButton(Const inTag: String); 47 | Function FindTagButton(Const inTag: String): TTagComponent; 48 | protected 49 | Procedure Loaded; Override; 50 | public 51 | Constructor Create(AOwner: TComponent); Override; 52 | Destructor Destroy; Override; 53 | published 54 | Property SelectedTags: TStringList Read _selectedtags Write SetSelectedTags; 55 | Property TagWidth: Integer Read _tagwidth Write SetTagWidth Default 75; 56 | published // From TPanel 57 | property Align; 58 | property Alignment; 59 | property Anchors; 60 | property AutoSize; 61 | property BevelEdges; 62 | property BevelInner; 63 | property BevelKind; 64 | property BevelOuter; 65 | property BevelWidth; 66 | property BiDiMode; 67 | property BorderWidth; 68 | property BorderStyle; 69 | property Color; 70 | property Constraints; 71 | property Ctl3D; 72 | property DoubleBuffered; 73 | property DoubleBufferedMode; 74 | property Enabled; 75 | property FullRepaint; 76 | property Font; 77 | property Locked; 78 | property Padding; 79 | property ParentBiDiMode; 80 | property ParentBackground; 81 | property ParentColor; 82 | property ParentCtl3D; 83 | property ParentDoubleBuffered; 84 | property ParentFont; 85 | property ParentShowHint; 86 | property PopupMenu; 87 | property TabOrder; 88 | property TabStop; 89 | property Visible; 90 | property StyleElements; 91 | property StyleName; 92 | property OnAlignInsertBefore; 93 | property OnAlignPosition; 94 | property OnCanResize; 95 | property OnConstrainedResize; 96 | property OnContextPopup; 97 | property OnDblClick; 98 | property OnEnter; 99 | property OnExit; 100 | property OnGesture; 101 | property OnGetSiteInfo; 102 | property OnMouseActivate; 103 | property OnMouseDown; 104 | property OnMouseEnter; 105 | property OnMouseLeave; 106 | property OnMouseMove; 107 | property OnMouseUp; 108 | property OnResize; 109 | Property OnTagRemoved: TTagRemovedEvent Read _ontagremoved Write _ontagremoved; 110 | End; 111 | 112 | Implementation 113 | 114 | Uses System.SysUtils, WinApi.Windows, Vcl.Graphics, Vcl.Themes; 115 | 116 | // 117 | // TTagComponent 118 | // 119 | 120 | Procedure TTagComponent.CMMOUSEENTER(Var inMessage: TMessage); 121 | Begin 122 | inherited; 123 | 124 | _drawactive := True; 125 | 126 | Self.Repaint; 127 | End; 128 | 129 | Procedure TTagComponent.CMMOUSELEAVE(Var inMessage: TMessage); 130 | Begin 131 | inherited; 132 | 133 | _drawactive := False; 134 | 135 | Self.Repaint; 136 | End; 137 | 138 | Constructor TTagComponent.Create(AOwner: TComponent); 139 | Begin 140 | inherited; 141 | 142 | _drawactive := False; 143 | Self.ShowHint := True; 144 | Self.ParentBackground := True; 145 | End; 146 | 147 | Procedure TTagComponent.Paint; 148 | Var 149 | textrect: TRect; 150 | s: String; 151 | Begin 152 | Self.Canvas.Brush.Color := TStyleManager.ActiveStyle.GetStyleColor(scEdit); 153 | 154 | If _drawactive Then 155 | Begin 156 | Self.Canvas.Pen.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfWindowTextDisabled); 157 | Self.Canvas.Pen.Width := 2; 158 | End 159 | Else 160 | Begin 161 | Self.Canvas.Pen.Color := TStyleManager.ActiveStyle.GetStyleColor(scBorder); 162 | Self.Canvas.Pen.Width := 1; 163 | End; 164 | 165 | Self.Canvas.Polygon([ 166 | TPoint.Create(1, 1), // Top left point 167 | TPoint.Create(Self.ClientWidth - 8, 1), // Top right point 168 | TPoint.Create(Self.ClientWidth - 1, Self.ClientHeight Div 2), // Right arrowhead 169 | TPoint.Create(Self.ClientWidth - 8, Self.ClientHeight - 1), // Bottom right point 170 | TPoint.Create(1, Self.ClientHeight - 1), // Bottom left point 171 | TPoint.Create(8, Self.ClientHeight Div 2) // Left arrowtail 172 | ]); 173 | 174 | textrect := TRect.Create(10, 3, Self.ClientWidth - 10, Self.ClientHeight - 3); 175 | s := Trim(Self.Caption); 176 | 177 | Self.Canvas.Font.Assign(Self.Font); 178 | Self.Canvas.Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfWindowTextNormal); 179 | Self.Canvas.TextRect(textrect, s, [tfSingleLine, tfVerticalCenter, tfCenter, tfEndEllipsis]); 180 | End; 181 | 182 | // 183 | // TAETagEditor 184 | // 185 | 186 | Procedure TAETagEditor.AddTagButton(Const inTag: String); 187 | Var 188 | btn: TTagComponent; 189 | Begin 190 | If Assigned(FindTagButton(inTag)) Then 191 | Exit; 192 | 193 | btn := TTagComponent.Create(_scrollbox); 194 | btn.Parent := _scrollbox; 195 | btn.Height := 25; 196 | btn.Width := _tagwidth; 197 | btn.Caption := inTag; 198 | btn.Top := 0; 199 | btn.Height := _scrollbox.ClientHeight; 200 | btn.Anchors := [akLeft, akTop, akBottom]; 201 | btn.Left := ((_scrollbox.ComponentCount - 1) * _tagwidth) - _scrollbox.HorzScrollBar.Position; 202 | btn.OnClick := TagClick; 203 | btn.Hint := inTag; 204 | End; 205 | 206 | Constructor TAETagEditor.Create(AOwner: TComponent); 207 | Begin 208 | inherited; 209 | 210 | _selectedtags := TStringList.Create; 211 | _selectedtags.OnChange := SelectedTagsChanged; 212 | 213 | _scrollbox := TScrollBox.Create(Self); 214 | _scrollbox.Parent := Self; 215 | _scrollbox.Align := alClient; 216 | _scrollbox.BorderStyle := bsNone; 217 | _scrollbox.HorzScrollBar.Smooth := True; 218 | _scrollbox.HorzScrollBar.Tracking := True; 219 | _scrollbox.UseWheelForScrolling := True; 220 | _scrollbox.ParentBackground := True; 221 | 222 | _tagwidth := 75; 223 | End; 224 | 225 | Destructor TAETagEditor.Destroy; 226 | Begin 227 | FreeAndNil(_selectedtags); 228 | 229 | inherited; 230 | End; 231 | 232 | Function TAETagEditor.FindTagButton(Const inTag: String): TTagComponent; 233 | Var 234 | a: NativeInt; 235 | Begin 236 | Result := nil; 237 | 238 | For a := 0 To _scrollbox.ComponentCount - 1 Do 239 | If (_scrollbox.Components[a] As TTagComponent).Caption = inTag Then 240 | Begin 241 | Result := TTagComponent(_scrollbox.Components[a]); 242 | 243 | Exit; 244 | End; 245 | End; 246 | 247 | procedure TAETagEditor.Loaded; 248 | begin 249 | inherited; 250 | 251 | _scrollbox.ParentBackground := True; 252 | end; 253 | 254 | Procedure TAETagEditor.RemoveButton(Const inTag: String); 255 | Var 256 | a: NativeInt; 257 | found: Boolean; 258 | Begin 259 | found := False; 260 | 261 | _scrollbox.LockDrawing; 262 | Try 263 | a := 0; 264 | 265 | While a < _scrollbox.ComponentCount Do 266 | Begin 267 | If found Then 268 | Begin 269 | TTagComponent(_scrollbox.Components[a]).Left := (a * _tagwidth) - _scrollbox.HorzScrollBar.Position; 270 | 271 | Inc(a); 272 | End 273 | Else If TTagComponent(_scrollbox.Components[a]).Caption = inTag Then 274 | Begin 275 | _scrollbox.Components[a].Free; 276 | 277 | Self.TagRemoved(inTag); 278 | 279 | found := True; 280 | End 281 | Else 282 | Inc(a); 283 | End; 284 | 285 | For a := 0 To _scrollbox.ComponentCount - 1 Do 286 | TTagComponent(_scrollbox.Components[a]).Height := _scrollbox.ClientHeight; 287 | Finally 288 | _scrollbox.UnlockDrawing; 289 | End; 290 | End; 291 | 292 | Procedure TAETagEditor.SelectedTagsChanged(Sender: TObject); 293 | Var 294 | a: NativeInt; 295 | Begin 296 | _scrollbox.LockDrawing; 297 | Try 298 | For a := 0 To _selectedtags.Count - 1 Do 299 | If Not Assigned(FindTagButton(_selectedtags[a])) Then 300 | AddTagButton(_selectedtags[a]); 301 | 302 | a := 0; 303 | 304 | While a < _scrollbox.ComponentCount Do 305 | If Not _selectedtags.Contains(TTagComponent(_scrollbox.Components[a]).Caption) Then 306 | RemoveButton(TTagComponent(_scrollbox.Components[a]).Caption) 307 | Else 308 | Inc(a); 309 | Finally 310 | _scrollbox.UnlockDrawing; 311 | End; 312 | End; 313 | 314 | Procedure TAETagEditor.SetSelectedTags(Const inSelectedTags: TStringList); 315 | Begin 316 | _selectedtags.Assign(inSelectedTags); 317 | End; 318 | 319 | Procedure TAETagEditor.SetTagWidth(Const inTagWidth: Integer); 320 | Var 321 | a: NativeInt; 322 | Begin 323 | If inTagWidth = _tagwidth Then 324 | Exit; 325 | 326 | _tagwidth := inTagWidth; 327 | 328 | _scrollbox.LockDrawing; 329 | Try 330 | For a := 0 To _scrollbox.ComponentCount - 1 Do 331 | Begin 332 | TTagComponent(_scrollbox.Components[a]).Left := a * _tagwidth; 333 | TTagComponent(_scrollbox.Components[a]).Width := _tagwidth; 334 | End; 335 | Finally 336 | _scrollbox.UnlockDrawing; 337 | End; 338 | End; 339 | 340 | Procedure TAETagEditor.TagClick(Sender: TObject); 341 | Var 342 | a: NativeInt; 343 | Begin 344 | For a := 0 To _selectedtags.Count - 1 Do 345 | If _selectedtags[a] = TTagComponent(Sender).Caption Then 346 | Begin 347 | _selectedtags.Delete(a); 348 | 349 | Break; 350 | End; 351 | End; 352 | 353 | Procedure TAETagEditor.TagRemoved(Const inTag: String); 354 | Begin 355 | If Assigned(_ontagremoved) Then 356 | _ontagremoved(Self, inTag); 357 | End; 358 | 359 | Procedure TAETagEditor.WMREMOVEBTN(Var inMessage: TMessage); 360 | Begin 361 | inMessage.Result := 0; 362 | 363 | Self.RemoveButton(TTagComponent(_scrollbox.Components[Integer(inMessage.WParam)]).Caption); 364 | End; 365 | 366 | End. 367 | -------------------------------------------------------------------------------- /3rdParty/OSVersion.pas: -------------------------------------------------------------------------------- 1 | // 2 | // Origin: Unknown 3 | // Collected from: Unknown 4 | // 5 | // Purpose: Get the OS name and version number in a standardized format 6 | // 7 | 8 | Unit OSVersion; 9 | 10 | Interface 11 | 12 | {$IFDEF MSWINDOWS} 13 | Uses Windows, SysUtils, TlHelp32; 14 | 15 | Type 16 | TGPI = Function(dwOSMajorVersion, dwOSMinorVersion, dwSpMajorVersion, 17 | dwSpMinorVersion: DWORD; var pdwReturnedProductType: DWORD): BOOL; stdcall; 18 | 19 | Function GetOSVersionInfo(Var Info: TOSVersionInfoEx): Boolean; 20 | Function IsWow64: Boolean; 21 | Function GetOSVersionText: String; 22 | {$ENDIF} 23 | 24 | Implementation 25 | 26 | {$IFDEF MSWINDOWS} 27 | Function GetOSVersionInfo(Var Info: TOSVersionInfoEx): Boolean; 28 | Begin 29 | FillChar(Info, SizeOf(TOSVersionInfoEx), 0); 30 | Info.dwOSVersionInfoSize := SizeOf(TOSVersionInfoEx); 31 | Result := GetVersionEx(TOSVersionInfo(Addr(Info)^)); 32 | If Not Result Then 33 | Begin 34 | FillChar(Info, SizeOf(TOSVersionInfoEx), 0); 35 | Info.dwOSVersionInfoSize := SizeOf(TOSVersionInfoEx); 36 | Result := GetVersionEx(TOSVersionInfo(Addr(Info)^)); 37 | If Not Result Then 38 | Info.dwOSVersionInfoSize := 0; 39 | End; 40 | end; 41 | 42 | function ProcessRuns(exeFileName: String): Boolean; 43 | var 44 | ContinueLoop: BOOL; 45 | FSnapshotHandle: THandle; 46 | FProcessEntry32: TProcessEntry32; 47 | begin 48 | FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); 49 | FProcessEntry32.dwSize := SizeOf(FProcessEntry32); 50 | ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); 51 | Result := False; 52 | While Integer(ContinueLoop) <> 0 Do 53 | Begin 54 | If ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) 55 | = UpperCase(exeFileName)) Or (UpperCase(FProcessEntry32.szExeFile) 56 | = UpperCase(exeFileName))) Then 57 | Begin 58 | Result := True; 59 | Break; 60 | End; 61 | ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); 62 | End; 63 | CloseHandle(FSnapshotHandle); 64 | end; 65 | 66 | function IsWow64: Boolean; 67 | Type 68 | TIsWow64Process = function(Handle: THandle; var Res: BOOL): BOOL; stdcall; 69 | Var 70 | IsWow64Result: BOOL; 71 | IsWow64Process: TIsWow64Process; 72 | Begin 73 | IsWow64Process := GetProcAddress(GetModuleHandle('kernel32.dll'), 74 | 'IsWow64Process'); 75 | If Assigned(IsWow64Process) And IsWow64Process(GetCurrentProcess, 76 | IsWow64Result) Then 77 | Result := IsWow64Result 78 | Else 79 | Result := False; 80 | end; 81 | 82 | function GetOSVersionText: string; 83 | Var 84 | vn: Cardinal; 85 | Info: TOSVersionInfoEx; 86 | dwType: DWORD; 87 | pGPI: TGPI; 88 | server: Boolean; 89 | begin 90 | Result := ''; 91 | If Not GetOSVersionInfo(Info) Then 92 | Exit; 93 | vn := Info.dwMajorVersion * 10 + Info.dwMinorVersion; 94 | server := Info.wProductType <> VER_NT_WORKSTATION; 95 | 96 | Case vn Of 97 | 50: 98 | If server Then 99 | Result := 'Windows Server 2000 ' 100 | Else 101 | Result := 'Windows 2000 '; 102 | 51: 103 | Result := 'Windows XP '; 104 | 52: 105 | If server Then 106 | Begin 107 | Result := 'Windows Server 2003 '; 108 | If GetSystemMetrics(SM_SERVERR2) <> 0 Then 109 | Result := Result + 'R2 '; 110 | End 111 | Else 112 | Result := 'Windows XP '; 113 | 60: 114 | If server Then 115 | Result := 'Windows Server 2008 ' 116 | Else 117 | Result := 'Windows Vista '; 118 | 61: 119 | If server Then 120 | Result := 'Windows Server 2008 R2 ' 121 | Else 122 | Result := 'Windows 7 '; 123 | 62: 124 | If server Then 125 | Result := 'Windows Server 2012 ' 126 | Else 127 | Result := 'Windows 8 '; 128 | 63: 129 | If server Then 130 | Result := 'Windows Server 2012 R2 ' 131 | Else 132 | Result := 'Windows 8.1 '; 133 | 64, 100: 134 | Begin 135 | If server And (Info.dwBuildNumber < 17677) Then 136 | Begin 137 | Result := 'Windows Server 2016 '; 138 | Case Info.dwBuildNumber Of 139 | 14300: 140 | Result := Result + '1010 '; 141 | 14393: 142 | Result := Result + '1607 '; 143 | 16299: 144 | Result := Result + '1709 '; 145 | 17134: 146 | Result := Result + '1803 '; 147 | End; 148 | End 149 | Else If vn = 100 Then 150 | If Info.dwBuildNumber < 22000 Then 151 | If server Then 152 | Begin 153 | Result := 'Windows Server 2019 '; 154 | Case Info.dwBuildNumber Of 155 | 17677: 156 | Result := Result + '1803 '; 157 | 17763: 158 | Result := Result + '1809 '; 159 | 18362: 160 | Result := Result + '1903 '; 161 | 18363: 162 | Result := Result + '1909 '; 163 | 19041: 164 | Result := Result + '2004 '; 165 | End; 166 | End 167 | Else 168 | Begin 169 | Result := 'Windows 10 '; 170 | Case Info.dwBuildNumber Of 171 | 10240: 172 | Result := Result + '1507 '; 173 | 10586: 174 | Result := Result + '1511 '; 175 | 14393: 176 | Result := Result + '1607 '; 177 | 15063: 178 | Result := Result + '1703 '; 179 | 16299: 180 | Result := Result + '1709 '; 181 | 17134: 182 | Result := Result + '1803 '; 183 | 17763: 184 | Result := Result + '1809 '; 185 | 18362: 186 | Result := Result + '1903 '; 187 | 18363: 188 | Result := Result + '1909 '; 189 | 19041: 190 | Result := Result + '2004 '; 191 | 19042: 192 | Result := Result + '20H2 '; 193 | 19043: 194 | Result := Result + '21H1 '; 195 | 19044: 196 | Result := Result + '21H2 '; 197 | End; 198 | End 199 | Else If server Then 200 | Begin 201 | Result := 'Windows Server 2022 '; 202 | End 203 | Else 204 | Begin 205 | Result := 'Windows 11 '; 206 | Case Info.dwBuildNumber Of 207 | 22000: 208 | Result := Result + '21H2 '; 209 | End; 210 | End; 211 | End; 212 | Else 213 | Begin 214 | Result := 'Windows '; 215 | If server Then 216 | Result := Result + 'Server ' 217 | Else 218 | Result := Result + 'Workstation '; 219 | Result := Result + IntToStr(Info.dwMajorVersion) + '.' + 220 | IntToStr(Info.dwMinorVersion) + ' '; 221 | End; 222 | End; 223 | dwType := 0; 224 | @pGPI := GetProcAddress(GetModuleHandle('kernel32.dll'), 'GetProductInfo'); 225 | If Assigned(pGPI) Then 226 | Begin 227 | pGPI(Info.dwMajorVersion, Info.dwMinorVersion, 0, 0, dwType); 228 | Case dwType Of 229 | PRODUCT_BUSINESS: 230 | Result := Result + 'Business'; 231 | PRODUCT_BUSINESS_N: 232 | Result := Result + 'Business N'; 233 | PRODUCT_CLUSTER_SERVER: 234 | Result := Result + 'Cluster Server'; 235 | PRODUCT_DATACENTER_SERVER: 236 | Result := Result + 'Datacenter'; 237 | PRODUCT_DATACENTER_SERVER_CORE: 238 | Result := Result + 'Datacenter Core'; 239 | PRODUCT_DATACENTER_SERVER_CORE_V: 240 | Result := Result + 'Core Datacenter (without Hyper-V)'; 241 | PRODUCT_DATACENTER_SERVER_V: 242 | Result := Result + 'Datacenter (without Hyper-V)'; 243 | PRODUCT_ENTERPRISE: 244 | Result := Result + 'Enterprise'; 245 | PRODUCT_ENTERPRISE_N: 246 | Result := Result + 'Enterprise N'; 247 | PRODUCT_ENTERPRISE_SERVER: 248 | Result := Result + 'Enterprise'; 249 | PRODUCT_ENTERPRISE_SERVER_CORE: 250 | Result := Result + 'Enterprise Core'; 251 | PRODUCT_ENTERPRISE_SERVER_CORE_V: 252 | Result := Result + 'Enterprise Core (without Hyper-V)'; 253 | PRODUCT_ENTERPRISE_SERVER_IA64: 254 | Result := Result + 'Enterprise for Itanium-based systems'; 255 | PRODUCT_ENTERPRISE_SERVER_V: 256 | Result := Result + 'Enterprise (without Hyper-V)'; 257 | PRODUCT_HOME_BASIC: 258 | Result := Result + 'Home Basic'; 259 | PRODUCT_HOME_BASIC_N: 260 | Result := Result + 'Home Basic N'; 261 | PRODUCT_HOME_PREMIUM: 262 | Result := Result + 'Home Premium'; 263 | PRODUCT_HOME_PREMIUM_N: 264 | Result := Result + 'Home Premium N'; 265 | PRODUCT_HYPERV: 266 | Result := Result + 'Hyper-V'; 267 | PRODUCT_PROFESSIONAL: 268 | Result := Result + 'Professional'; 269 | PRODUCT_PROFESSIONAL_N: 270 | Result := Result + 'Profesional N'; 271 | PRODUCT_SMALLBUSINESS_SERVER: 272 | Result := Result + 'Small Business'; 273 | PRODUCT_SMALLBUSINESS_SERVER_PREMIUM: 274 | Result := Result + 'Small Business Premium'; 275 | PRODUCT_STANDARD_SERVER: 276 | Result := Result + 'Standard'; 277 | PRODUCT_STANDARD_SERVER_CORE: 278 | Result := Result + 'Standard Core'; 279 | PRODUCT_STANDARD_SERVER_CORE_V: 280 | Result := Result + 'Standard Core (without Hyper-V)'; 281 | PRODUCT_STANDARD_SERVER_V: 282 | Result := Result + 'Standard (without Hyper-V)'; 283 | PRODUCT_STARTER: 284 | Result := Result + ' Starter'; 285 | PRODUCT_STORAGE_ENTERPRISE_SERVER: 286 | Result := Result + 'Storage Enterprise'; 287 | PRODUCT_STORAGE_EXPRESS_SERVER: 288 | Result := Result + 'Storage Express'; 289 | PRODUCT_STORAGE_STANDARD_SERVER: 290 | Result := Result + 'Storage Standard'; 291 | PRODUCT_STORAGE_WORKGROUP_SERVER: 292 | Result := Result + 'Storage Workgroup'; 293 | PRODUCT_ULTIMATE: 294 | Result := Result + 'Ultimate'; 295 | PRODUCT_ULTIMATE_N: 296 | Result := Result + 'Ultimate N'; 297 | PRODUCT_WEB_SERVER: 298 | Result := Result + 'Web'; 299 | PRODUCT_WEB_SERVER_CORE: 300 | Result := Result + 'Web Core'; 301 | Else 302 | dwType := 0; 303 | End; 304 | End; 305 | If dwType = 0 Then 306 | Begin 307 | If Not server Then 308 | If Info.wSuiteMask And VER_SUITE_PERSONAL > 0 Then 309 | Result := Result + 'Home' 310 | Else 311 | Result := Result + 'Professional' 312 | Else 313 | Begin 314 | If Info.wSuiteMask And VER_SUITE_BLADE > 0 Then 315 | Result := Result + 'Web' 316 | Else If Info.wSuiteMask And VER_SUITE_DATACENTER > 0 Then 317 | Result := Result + 'Data Center' 318 | Else If Info.wSuiteMask And VER_SUITE_ENTERPRISE > 0 Then 319 | Result := Result + 'Enterprise' 320 | Else If Info.wSuiteMask And VER_SUITE_EMBEDDEDNT > 0 Then 321 | Result := Result + 'Embedded' 322 | Else 323 | Result := Result + 'Standard'; 324 | End; 325 | End; 326 | If (vn >= 62) And server And Not ProcessRuns('dwm.exe') Then 327 | Result := Result + ' Core'; 328 | If Info.wServicePackMajor > 0 Then 329 | Begin 330 | Result := Result + ' SP' + IntToStr(Info.wServicePackMajor); 331 | If Info.wServicePackMinor > 0 Then 332 | Result := Result + '.' + IntToStr(Info.wServicePackMinor); 333 | Result := Result; 334 | End; 335 | {$IFDEF WIN32} If IsWow64 Then {$ENDIF} Result := Result + ' x64'; 336 | end; 337 | 338 | {$ENDIF} 339 | end. 340 | -------------------------------------------------------------------------------- /AE.IDE/AE.IDE.DelphiVersions.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.IDE.DelphiVersions; 10 | 11 | Interface 12 | 13 | Uses System.SysUtils, AE.DDEManager, AE.IDE.Versions, System.Win.Registry, System.Classes; 14 | 15 | Type 16 | TAEDelphiInstance = Class(TAEIDEInstance) 17 | strict protected 18 | Procedure InternalFindIDEWindow; Override; 19 | Procedure InternalOpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal = 5000); Override; 20 | End; 21 | 22 | TAEBorlandDelphiVersion = Class(TAEIDEVersion) 23 | strict private 24 | _ddeansimode: Boolean; 25 | _ddediscoverytimeout: Cardinal; 26 | _ddeservice: String; 27 | _ddetopic: String; 28 | Procedure SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 29 | strict protected 30 | Procedure InternalRefreshInstances; Override; 31 | Function InternalGetEdition: String; Override; 32 | Function InternalGetName: String; Override; 33 | Property InternalDDEANSIMode: Boolean Read _ddeansimode Write _ddeansimode; 34 | Property InternalDDEService: String Read _ddeservice Write _ddeservice; 35 | Property InternalDDETopic: String Read _ddetopic Write _ddetopic; 36 | public 37 | Class Function BDSRoot: String; Virtual; 38 | Constructor Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer; Const inDDEDiscoveryTimeout: Cardinal); ReIntroduce; Virtual; 39 | Property DDEANSIMode: Boolean Read _ddeansimode; 40 | Property DDEDiscoveryTimeout: Cardinal Read _ddediscoverytimeout Write SetDDEDiscoveryTimeout; 41 | Property DDEService: String Read _ddeservice; 42 | Property DDETopic: String Read _ddetopic; 43 | End; 44 | 45 | TAEDelphiVersionClass = Class Of TAEBorlandDelphiVersion; 46 | 47 | TAEBorland2DelphiVersion = Class(TAEBorlandDelphiVersion) 48 | strict protected 49 | Function InternalGetName: String; Override; 50 | public 51 | Class Function BDSRoot: String; Override; 52 | End; 53 | 54 | TAECodegearDelphiVersion = Class(TAEBorlandDelphiVersion) 55 | strict protected 56 | Function InternalGetName: String; Override; 57 | public 58 | Class Function BDSRoot: String; Override; 59 | Constructor Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer; Const inDiscoveryTimeout: Cardinal); Override; 60 | End; 61 | 62 | TAEEmbarcaderoDelphiVersion = Class(TAECodegearDelphiVersion) 63 | strict protected 64 | Function InternalGetName: String; Override; 65 | public 66 | Class Function BDSRoot: String; Override; 67 | End; 68 | 69 | TAEDelphiVersions = Class(TAEIDEVersions) 70 | strict private 71 | _ddediscoverytimeout: Cardinal; 72 | Procedure DiscoverVersions(Const inRegistry: TRegistry; Const inDelphiVersionClass: TAEDelphiVersionClass); 73 | Procedure SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 74 | strict protected 75 | Procedure InternalRefreshInstalledVersions; Override; 76 | public 77 | Constructor Create(inOwner: TComponent); Override; 78 | Property DDEDiscoveryTimeout: Cardinal Read _ddediscoverytimeout Write SetDDEDiscoveryTimeout; 79 | End; 80 | 81 | EAEDelphiVersionException = Class(Exception); 82 | 83 | Implementation 84 | 85 | Uses WinApi.Windows, AE.IDE.Versions.Consts, AE.Misc.FileUtils; 86 | 87 | Const 88 | MINDELPHIVERSION = 3; 89 | MAXDELPHIVERSION = 23; 90 | 91 | Function FindDelphiWindow(inHWND: HWND; inParam: LParam): Boolean; StdCall; 92 | Var 93 | ppid: Cardinal; 94 | title, classname: Array[0..255] Of Char; 95 | Begin 96 | // https://docs.microsoft.com/en-us/previous-versions/windows/desktop/legacy/ms633498(v=vs.85) 97 | // Result := True -> Continue evaluation 98 | // Result := False -> Do not continue evaluation 99 | 100 | GetWindowThreadProcessID(inHWND, ppid); 101 | GetWindowText(inHWND, title, 255); 102 | GetClassName(inHWND, classname, 255); 103 | 104 | Result := (ppid <> PAEIDEInfo(inParam)^.PID) Or Not IsWindowVisible(inHWND) Or Not IsWindowEnabled(inHWND) Or 105 | Not (String(title).Contains('RAD Studio') Or String(title).Contains('Delphi')) Or (String(classname) <> 'TAppBuilder'); 106 | 107 | If Not Result Then 108 | Begin 109 | PAEIDEInfo(inParam)^.outHWND := inHWND; 110 | PAEIDEInfo(inParam)^.outWindowCaption := title; 111 | End; 112 | End; 113 | 114 | // 115 | // TAEDelphiInstance 116 | // 117 | 118 | Procedure TAEDelphiInstance.InternalFindIDEWindow; 119 | Var 120 | info: PAEIDEInfo; 121 | Begin 122 | inherited; 123 | 124 | New(info); 125 | Try 126 | info^.PID := Self.PID; 127 | info^.outHWND := 0; 128 | info^.outWindowCaption := ''; 129 | 130 | EnumWindows(@FindDelphiWindow, LParam(info)); 131 | 132 | SetIDEHWND(info^.outHWND); 133 | SetIDECaption(info^.outWindowCaption); 134 | Finally 135 | Dispose(info); 136 | End; 137 | End; 138 | 139 | Procedure TAEDelphiInstance.InternalOpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal = 5000); 140 | Var 141 | ddemgr: TAEDDEManager; 142 | version: TAEBorlandDelphiVersion; 143 | Begin 144 | inherited; 145 | 146 | version := Self.Owner As TAEBorlandDelphiVersion; 147 | 148 | ddemgr := TAEDDEManager.Create(version.DDEService, version.DDETopic, version.DDEANSIMode, version.DDEDiscoveryTimeout); 149 | Try 150 | While Not ddemgr.ServerFound(Self.PID) Do 151 | Begin 152 | If Self.InternalAbortOpenFile Then 153 | Exit; 154 | 155 | Sleep(1000); 156 | ddemgr.RefreshServers; 157 | End; 158 | 159 | ddemgr.ExecuteCommand('[open("' + inFileName + '")]', Self.PID, inTimeOutInMs); 160 | Finally 161 | FreeAndNil(ddemgr); 162 | End; 163 | End; 164 | 165 | // 166 | // TAEBorlandDelphiVersion 167 | // 168 | 169 | Class Function TAEBorlandDelphiVersion.BDSRoot: String; 170 | Begin 171 | Result := 'SOFTWARE\Borland\Delphi'; 172 | End; 173 | 174 | Procedure TAEBorlandDelphiVersion.InternalRefreshInstances; 175 | Var 176 | pid: Cardinal; 177 | ddemgr: TAEDDEManager; 178 | Begin 179 | inherited; 180 | 181 | ddemgr := TAEDDEManager.Create(Self.DDEService, Self.DDETopic, Self.DDEANSIMode, Self.DDEDiscoveryTimeout); 182 | Try 183 | For pid In ddemgr.DDEServerPIDs Do 184 | If ProcessName(pid).ToLower = Self.ExecutablePath.ToLower Then 185 | AddInstance(TAEDelphiInstance.Create(Self, pid)); 186 | Finally 187 | FreeAndNil(ddemgr); 188 | End; 189 | End; 190 | 191 | Procedure TAEBorlandDelphiVersion.SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 192 | Begin 193 | If inDDEDiscoveryTimeout = _ddediscoverytimeout Then 194 | Exit; 195 | 196 | _ddediscoverytimeout := inDDEDiscoveryTimeout; 197 | 198 | Self.RefreshInstances; 199 | End; 200 | 201 | Constructor TAEBorlandDelphiVersion.Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer; Const inDDEDiscoveryTimeout: Cardinal); 202 | Begin 203 | inherited Create(inOwner, inExecutablePath, inVersionNumber); 204 | 205 | _ddeansimode := True; 206 | _ddediscoverytimeout := inDDEDiscoveryTimeout; 207 | _ddeservice := 'delphi32'; 208 | _ddetopic := 'system'; 209 | end; 210 | 211 | Function TAEBorlandDelphiVersion.InternalGetEdition: String; 212 | Begin 213 | Result := FileInfo(Self.ExecutablePath, 'ProductName'); 214 | End; 215 | 216 | Function TAEBorlandDelphiVersion.InternalGetName: String; 217 | Begin 218 | Case Self.VersionNumber Of 219 | 6: 220 | Result := IDEVER_DELPHI6; 221 | 7: 222 | Result := IDEVER_DELPHI7; 223 | Else 224 | Result := ''; 225 | End; 226 | 227 | // IMPORTANT! IN CASE NEW VERSIONS ARE ADDED, MODIFY THE MAXDELPHIVERSION CONSTANT ACCORDINGLY FOR PROPER REGISTRY ENTRY VALIDATION! 228 | End; 229 | 230 | // 231 | // TAEBorland2DelphiVersion 232 | // 233 | 234 | Class function TAEBorland2DelphiVersion.BDSRoot: String; 235 | Begin 236 | Result := 'SOFTWARE\Borland\BDS'; 237 | End; 238 | 239 | Function TAEBorland2DelphiVersion.InternalGetName: String; 240 | Begin 241 | Case Self.VersionNumber Of 242 | 3: 243 | Result := IDEVER_DELPHI2005; 244 | 4: 245 | Result := IDEVER_DELPHI2006; 246 | 5: 247 | Result := IDEVER_DELPHI2007; 248 | Else 249 | Result := ''; 250 | End; 251 | 252 | // IMPORTANT! IN CASE NEW VERSIONS ARE ADDED, MODIFY THE MAXDELPHIVERSION CONSTANT ACCORDINGLY FOR PROPER REGISTRY ENTRY VALIDATION! 253 | End; 254 | 255 | // 256 | // TAECodegearDelphiVersion 257 | // 258 | 259 | Class Function TAECodegearDelphiVersion.BDSRoot: String; 260 | Begin 261 | Result := 'SOFTWARE\CodeGear\BDS'; 262 | End; 263 | 264 | Constructor TAECodegearDelphiVersion.Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer; Const inDiscoveryTimeout: Cardinal); 265 | Begin 266 | inherited; 267 | 268 | Self.InternalDDEService := 'bds'; 269 | 270 | // The first Unicode version was Delphi 2009 271 | Self.InternalDDEANSIMode := False; 272 | End; 273 | 274 | Function TAECodegearDelphiVersion.InternalGetName: String; 275 | Begin 276 | Case Self.VersionNumber Of 277 | 6: 278 | Result := IDEVER_DELPHI2009; 279 | 7: 280 | Result := IDEVER_DELPHI2010; 281 | Else 282 | Result := ''; 283 | End; 284 | End; 285 | 286 | // 287 | // TAEEmbarcaderoDelphiVersion 288 | // 289 | 290 | Class Function TAEEmbarcaderoDelphiVersion.BDSRoot: String; 291 | Begin 292 | Result := 'SOFTWARE\Embarcadero\BDS'; 293 | End; 294 | 295 | Function TAEEmbarcaderoDelphiVersion.InternalGetName: String; 296 | Begin 297 | Case Self.VersionNumber Of 298 | 8: 299 | Result := IDEVER_DELPHIXE; 300 | 9: 301 | Result := IDEVER_DELPHIXE2; 302 | 10: 303 | Result := IDEVER_DELPHIXE3; 304 | 11: 305 | Result := IDEVER_DELPHIXE4; 306 | 12: 307 | Result := IDEVER_DELPHIXE5; 308 | 14: 309 | Result := IDEVER_DELPHIXE6; 310 | 15: 311 | Result := IDEVER_DELPHIXE7; 312 | 16: 313 | Result := IDEVER_DELPHIXE8; 314 | 17: 315 | Result := IDEVER_DELPHI10; 316 | 18: 317 | Result := IDEVER_DELPHI101; 318 | 19: 319 | Result := IDEVER_DELPHI102; 320 | 20: 321 | Result := IDEVER_DELPHI103; 322 | 21: 323 | Result := IDEVER_DELPHI104; 324 | 22: 325 | Result := IDEVER_DELPHI11; 326 | 23: 327 | Result := IDEVER_DELPHI12; 328 | Else 329 | Result := ''; 330 | End; 331 | 332 | // IMPORTANT! IN CASE NEW VERSIONS ARE ADDED, MODIFY THE MAXDELPHIVERSION CONSTANT ACCORDINGLY FOR PROPER REGISTRY ENTRY VALIDATION! 333 | End; 334 | 335 | // 336 | // TAEDelphiVersions 337 | // 338 | 339 | Constructor TAEDelphiVersions.Create(inOwner: TComponent); 340 | Begin 341 | inherited; 342 | 343 | _ddediscoverytimeout := 1; 344 | End; 345 | 346 | Procedure TAEDelphiVersions.DiscoverVersions(Const inRegistry: TRegistry; Const inDelphiVersionClass: TAEDelphiVersionClass); 347 | Var 348 | s: String; 349 | sl: TStringList; 350 | vernumber: Integer; 351 | Begin 352 | sl := TStringList.Create; 353 | Try 354 | If Not inRegistry.OpenKey(inDelphiVersionClass.BDSRoot, False) Then 355 | Exit; 356 | 357 | Try 358 | inRegistry.GetKeyNames(sl); 359 | Finally 360 | inRegistry.CloseKey; 361 | End; 362 | 363 | sl.Sort; 364 | 365 | For s In sl Do 366 | Begin 367 | If Not inRegistry.OpenKey(inDelphiVersionClass.BDSRoot + '\' + s, False) Then 368 | Continue; 369 | 370 | Try 371 | // Entries in the registry might be invalid keys (e.g. not created by Delphi installer) 372 | // See a valid report at https://en.delphipraxis.net/topic/8086-ae-bdslauncher/?do=findComment&comment=68459 373 | // To avoid an exception in this case, try to validate it 374 | 375 | If Not Integer.TryParse(s.Substring(0, s.IndexOf('.')), vernumber) Or (vernumber < MINDELPHIVERSION) Or (vernumber > MAXDELPHIVERSION) Or 376 | Not inRegistry.ValueExists('App') Then 377 | Continue; 378 | 379 | Self.AddVersion(inDelphiVersionClass.Create(Self, inRegistry.ReadString('App'), vernumber, _ddediscoverytimeout)); 380 | Finally 381 | inRegistry.CloseKey; 382 | End; 383 | End; 384 | Finally 385 | FreeAndNil(sl); 386 | End; 387 | End; 388 | 389 | Procedure TAEDelphiVersions.InternalRefreshInstalledVersions; 390 | Var 391 | reg: TRegistry; 392 | Begin 393 | inherited; 394 | 395 | reg := TRegistry.Create; 396 | Try 397 | reg.RootKey := HKEY_CURRENT_USER; 398 | 399 | DiscoverVersions(reg, TAEBorlandDelphiVersion); 400 | DiscoverVersions(reg, TAEBorland2DelphiVersion); 401 | DiscoverVersions(reg, TAECodegearDelphiVersion); 402 | DiscoverVersions(reg, TAEEmbarcaderoDelphiVersion); 403 | Finally 404 | FreeAndNil(reg); 405 | End; 406 | End; 407 | 408 | Procedure TAEDelphiVersions.SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 409 | Var 410 | ver: TAEIDEVersion; 411 | Begin 412 | If inDDEDiscoveryTimeout = _ddediscoverytimeout Then 413 | Exit; 414 | 415 | _ddediscoverytimeout := inDDEDiscoveryTimeout; 416 | 417 | For ver In Self.InstalledVersions Do 418 | (ver As TAEBorlandDelphiVersion).DDEDiscoveryTimeout := inDDEDiscoveryTimeout; 419 | End; 420 | 421 | End. 422 | -------------------------------------------------------------------------------- /AE.Updater/AE.Comp.Updater.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.Comp.Updater; 10 | 11 | Interface 12 | 13 | Uses System.Classes, AE.Comp.Updater.UpdateFile, System.SysUtils, System.Generics.Collections, AE.Comp.Updater.FileProvider; 14 | 15 | Type 16 | EAEUpdaterException = Class(Exception); 17 | 18 | TAEUpdater = Class(TComponent) 19 | strict private 20 | _availablemessages: TList; 21 | _availableupdates: TObjectDictionary>; 22 | _channel: TAEUpdaterChannel; 23 | _filehashes: TDictionary; 24 | _fileprovider: TAEUpdaterFileProvider; 25 | _lastmessagedate: UInt64; 26 | _localupdateroot: String; 27 | _product: String; 28 | _updatefile: TAEUpdateFile; 29 | Procedure CheckFileProvider; 30 | Procedure InternalCheckForUpdates; 31 | Procedure SetFileHash(Const inFileName, inFileHash: String); 32 | Procedure SetLocalUpdateRoot(Const inLocalUpdateRoot: String); 33 | Procedure SetProduct(Const inProduct: String); 34 | Function ChannelVisible(Const inChannel: TAEUpdaterChannel): Boolean; 35 | Function DownloadFile(Const inURL: String; Const outStream: TStream): Boolean; 36 | Function GetActualProduct: TAEUpdaterProduct; 37 | Function GetFileHash(Const inFileName: String): String; 38 | Function GetFileHashes: TArray; 39 | Function GetMessages: TArray; 40 | Function GetUpdateableFiles: TArray; 41 | Function GetUpdateableFileVersions(Const inFileName: String): TArray; 42 | public 43 | Class Procedure Cleanup(Const inLocalUpdateRoot: String = ''); 44 | Constructor Create(AOwner: TComponent); Override; 45 | Destructor Destroy; Override; 46 | Procedure CheckForUpdates; 47 | Procedure Rollback(Const inFileName: String); 48 | Procedure Update(Const inFileName: String; inVersion: UInt64 = 0); 49 | Property ActualProduct: TAEUpdaterProduct Read GetActualProduct; 50 | Property Channel: TAEUpdaterChannel Read _channel Write _channel; 51 | Property FileHash[Const inFileName: String]: String Read GetFileHash Write SetFileHash; 52 | Property FileHashes: TArray Read GetFileHashes; 53 | Property LastMessageDate: UInt64 Read _lastmessagedate Write _lastmessagedate; 54 | Function LoadUpdateFile: Boolean; 55 | Property LocalUpdateRoot: String Read _localupdateroot Write SetLocalUpdateRoot; 56 | Property Messages: TArray Read GetMessages; 57 | Property UpdateableFiles: TArray Read GetUpdateableFiles; 58 | Property UpdateableFileVersions[Const inFileName: String]: TArray Read GetUpdateableFileVersions; 59 | published 60 | Property FileProvider: TAEUpdaterFileProvider Read _fileprovider Write _fileprovider; 61 | Property Product: String Read _product Write SetProduct; 62 | End; 63 | 64 | Implementation 65 | 66 | Uses AE.Misc.FileUtils, System.IOUtils, System.Generics.Defaults; 67 | 68 | Const 69 | OLDVERSIONEXT = '.aeupdater.tmp'; 70 | 71 | Procedure TAEUpdater.CheckForUpdates; 72 | Var 73 | fname: String; 74 | fver: TFileVersion; 75 | Begin 76 | CheckFileProvider; 77 | 78 | _availablemessages.Clear; 79 | _availableupdates.Clear; 80 | 81 | // Verify files previously updated. If any of these files do not exist now OR the file hash is different, 82 | // clear all ETags causing the updater to actually download the update file and perform all verifications. 83 | For fname In _filehashes.Keys Do 84 | Begin 85 | fver := FileVersion(fname); 86 | If Not TFile.Exists(fname) Or (CompareText(_filehashes[fname], fver.MD5Hash) <> 0) Then 87 | Begin 88 | _fileprovider.ResetCache; 89 | Break; 90 | End; 91 | End; 92 | 93 | _filehashes.Clear; 94 | 95 | If Not LoadUpdateFile Then 96 | Exit; 97 | 98 | InternalCheckForUpdates; 99 | End; 100 | 101 | Procedure TAEUpdater.CheckFileProvider; 102 | Begin 103 | If Not Assigned(_fileprovider) Then 104 | Raise EAEUpdaterException.Create('File provider is not assigned!'); 105 | End; 106 | 107 | Class Procedure TAEUpdater.Cleanup(Const inLocalUpdateRoot: String = ''); 108 | Var 109 | fname, locupdate: String; 110 | Begin 111 | If inLocalUpdateRoot.IsEmpty Then 112 | locupdate := ExtractFilePath(ParamStr(0)) 113 | Else 114 | locupdate := inLocalUpdateRoot; 115 | 116 | For fname In TDirectory.GetFiles(locupdate, '*' + OLDVERSIONEXT, TSearchOption.soAllDirectories) Do 117 | TFile.Delete(fname); 118 | End; 119 | 120 | Constructor TAEUpdater.Create(AOwner: TComponent); 121 | Begin 122 | inherited; 123 | 124 | _availablemessages := TList.Create; 125 | _availableupdates := TObjectDictionary >.Create([doOwnsValues]); 126 | _channel := aucProduction; 127 | _filehashes := TDictionary.Create; 128 | _fileprovider := nil; 129 | _lastmessagedate := 0; 130 | _product := ''; 131 | _updatefile := TAEUpdateFile.Create; 132 | 133 | Self.LocalUpdateRoot := ''; 134 | End; 135 | 136 | Destructor TAEUpdater.Destroy; 137 | Begin 138 | FreeAndNil(_availablemessages); 139 | FreeAndNil(_availableupdates); 140 | FreeAndNil(_filehashes); 141 | FreeAndNil(_updatefile); 142 | 143 | inherited; 144 | End; 145 | 146 | Function TAEUpdater.DownloadFile(Const inURL: String; Const outStream: TStream): Boolean; 147 | Var 148 | prevsize: Int64; 149 | Begin 150 | CheckFileProvider; 151 | 152 | prevsize := outStream.Size; 153 | 154 | _fileprovider.ProvideFile(inURL, outStream); 155 | 156 | Result := outStream.Size > prevsize; 157 | End; 158 | 159 | Function TAEUpdater.LoadUpdateFile: Boolean; 160 | Var 161 | ms: TMemoryStream; 162 | Begin 163 | CheckFileProvider; 164 | 165 | Result := False; 166 | 167 | ms := TMemoryStream.Create; 168 | Try 169 | _fileprovider.ProvideUpdateFile(ms); 170 | 171 | If ms.Size = 0 Then 172 | Exit; 173 | 174 | ms.Position := 0; 175 | 176 | _updatefile.LoadFromStream(ms); 177 | 178 | Result := True; 179 | Finally 180 | FreeAndNil(ms); 181 | End; 182 | End; 183 | 184 | Procedure TAEUpdater.Rollback(Const inFileName: String); 185 | Begin 186 | If Not TFile.Exists(_localupdateroot + inFileName + OLDVERSIONEXT) Then 187 | Exit; 188 | 189 | If TFile.Exists(_localupdateroot + inFileName) Then 190 | TFile.Delete(_localupdateroot + inFileName); 191 | 192 | TFile.Move(_localupdateroot + inFileName + OLDVERSIONEXT, _localupdateroot + inFileName); 193 | End; 194 | 195 | Function TAEUpdater.GetActualProduct: TAEUpdaterProduct; 196 | Begin 197 | Result := _updatefile.Product[_product]; 198 | End; 199 | 200 | Function TAEUpdater.GetFileHash(Const inFileName: String): String; 201 | Begin 202 | _filehashes.TryGetValue(inFileName, Result); 203 | End; 204 | 205 | Function TAEUpdater.GetFileHashes: TArray; 206 | Begin 207 | Result := _filehashes.Keys.ToArray; 208 | End; 209 | 210 | Function TAEUpdater.GetMessages: TArray; 211 | Begin 212 | Result := _availablemessages.ToArray; 213 | 214 | TArray.Sort(Result, TComparer.Construct( 215 | Function(Const Left, Right: UInt64): Integer 216 | Begin 217 | Result := -1 * TComparer.Default.Compare(Left, Right); 218 | End 219 | )); 220 | End; 221 | 222 | Function TAEUpdater.GetUpdateableFiles: TArray; 223 | Begin 224 | Result := _availableupdates.Keys.ToArray; 225 | TArray.Sort(Result); 226 | End; 227 | 228 | Function TAEUpdater.GetUpdateableFileVersions(Const inFileName: String): TArray; 229 | Begin 230 | Result := _availableupdates[inFileName].ToArray; 231 | End; 232 | 233 | Procedure TAEUpdater.InternalCheckForUpdates; 234 | Var 235 | fname: String; 236 | a, b: UInt64; 237 | fver: TFileVersion; 238 | fexists: Boolean; 239 | product: TAEUpdaterProduct; 240 | pfile: TAEUpdaterProductFile; 241 | pver: TAEUpdaterProductFileVersion; 242 | Begin 243 | fname := FileInfo(ParamStr(0), 'OriginalFileName'); 244 | If fname.IsEmpty Then 245 | fname := ExtractFileName(ParamStr(0)); 246 | 247 | If Not _updatefile.ContainsProduct(_product) Then 248 | Exit; 249 | 250 | product := _updatefile.Product[_product]; 251 | 252 | If Not product.ContainsFile(fname) Then 253 | Raise EAEUpdaterException.Create(_product + ' does not contain a file named ' + fname); 254 | 255 | For fname In product.ProductFiles Do 256 | Begin 257 | pfile := product.ProductFile[fname]; 258 | fexists := TFile.Exists(_localupdateroot + fname); 259 | 260 | If Not fexists And pfile.Optional Then 261 | Continue; 262 | 263 | fver := FileVersion(_localupdateroot + fname); 264 | 265 | For a In pfile.Versions Do 266 | Begin 267 | pver := pfile.Version[a]; 268 | 269 | If (fver.VersionNumber = 0) And Not pver.FileHash.IsEmpty And (CompareText(pver.FileHash, fver.MD5Hash) = 0) Then 270 | fver.VersionNumber := a; 271 | 272 | If (pver.DeploymentDate = 0) Or Not ChannelVisible(pver.Channel) Then 273 | Continue; 274 | 275 | // A file is considered updateable, if any of these conditions are true: 276 | // - The file does not exist locally (a new file was deployed with an update) 277 | // - The version number of the local file can be determined and the current version in the update file is greater than the local 278 | // - The version number of the local file can not be determined or is equal to the current version in the update file, but the hashes mismatch 279 | If Not fexists Or 280 | ((a > fver.VersionNumber) And (fver.VersionNumber > 0)) Or 281 | (Not pver.FileHash.IsEmpty And ((fver.VersionNumber = 0) Or (a = fver.VersionNumber)) And (CompareText(pver.FileHash, fver.MD5Hash) <> 0)) Then 282 | Begin 283 | If Not _availableupdates.ContainsKey(fname) Then 284 | _availableupdates.Add(fname, TList.Create); 285 | _availableupdates[fname].Add(a); 286 | End 287 | Else 288 | // If the file is not updateable but the version number (or hash) is equal to the existing one, add it to the known hashes list 289 | If fexists And 290 | Not pver.FileHash.IsEmpty And 291 | ((fver.VersionNumber = 0) Or (a = fver.VersionNumber)) And 292 | (CompareText(pver.FileHash, fver.MD5Hash) = 0) Then 293 | _filehashes.Add(fname, fver.MD5Hash); 294 | End; 295 | End; 296 | 297 | b := 0; 298 | For a In product.Messages Do 299 | Begin 300 | If (a > _lastmessagedate) And ChannelVisible(product.Message[a].Channel) Then 301 | _availablemessages.Add(a); 302 | If a > b Then 303 | b := a; 304 | End; 305 | _lastmessagedate := b; 306 | End; 307 | 308 | Procedure TAEUpdater.SetFileHash(Const inFileName, inFileHash: String); 309 | Begin 310 | If Not inFileHash.IsEmpty Then 311 | _filehashes.AddOrSetValue(inFileName, inFileHash) 312 | Else 313 | _filehashes.Remove(inFileName); 314 | End; 315 | 316 | Procedure TAEUpdater.SetLocalUpdateRoot(const inLocalUpdateRoot: String); 317 | Begin 318 | If inLocalUpdateRoot.IsEmpty Then 319 | _localupdateroot := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))) 320 | Else 321 | _localupdateroot := IncludeTrailingPathDelimiter(inLocalUpdateRoot); 322 | End; 323 | 324 | Procedure TAEUpdater.SetProduct(Const inProduct: String); 325 | Begin 326 | _product := inProduct; 327 | _updatefile.ProductBind := inProduct; 328 | End; 329 | 330 | Procedure TAEUpdater.Update(Const inFileName: String; inVersion: UInt64 = 0); 331 | Var 332 | fs: TFileStream; 333 | fileurl, filepath: String; 334 | product: TAEUpdaterProduct; 335 | version: TAEUpdaterProductFileVersion; 336 | lfilever: TFileVersion; 337 | Begin 338 | CheckFileProvider; 339 | 340 | product := _updatefile.Product[_product]; 341 | 342 | If Not product.ContainsFile(inFileName) Then 343 | Raise EAEUpdaterException.Create(inFileName + ' does not exist in the current product!'); 344 | 345 | // If no version number was provided, use the available latest. Else, perform verification 346 | If inVersion = 0 Then 347 | inVersion := product.ProductFile[inFileName].LatestVersion 348 | Else 349 | If Not product.ProductFile[inFileName].ContainsVersion(inVersion) Then 350 | Raise EAEUpdaterException.Create('Version ' + FileVersionToString(inVersion) + ' does not exist for ' + inFileName + '!'); 351 | 352 | version := product.ProductFile[inFileName].Version[inVersion]; 353 | 354 | // To get the file's complete download URL, we concatenate: 355 | // - The update file URL, cutting down the update file name 356 | // - Current products base URL plus a forward slash 357 | // - Archive file name of the version 358 | fileurl := _fileprovider.UpdateRoot + version.RelativeArchiveFileName('/'); 359 | 360 | If TFile.Exists(_localupdateroot + inFileName + OLDVERSIONEXT) Then 361 | TFile.Delete(_localupdateroot + inFileName + OLDVERSIONEXT); 362 | 363 | If TFile.Exists(_localupdateroot + inFileName) Then 364 | TFile.Move(_localupdateroot + inFileName, _localupdateroot + inFileName + OLDVERSIONEXT); 365 | 366 | filepath := ExtractFilePath(inFileName); 367 | If Not filepath.IsEmpty And Not TDirectory.Exists(_localupdateroot + filepath) Then 368 | TDirectory.CreateDirectory(_localupdateroot + filepath); 369 | 370 | Try 371 | fs := TFileStream.Create(_localupdateroot + inFileName, fmCreate); 372 | Try 373 | If Not DownloadFile(fileurl, fs) Then 374 | TFile.Move(_localupdateroot + inFileName + OLDVERSIONEXT, _localupdateroot + inFileName); 375 | Finally 376 | fs.Free; 377 | End; 378 | 379 | lfilever := FileVersion(_localupdateroot + inFileName); 380 | 381 | If CompareText(lfilever.MD5Hash, version.FileHash) <> 0 Then 382 | Raise EAEUpdaterException.Create('Hash verification failed for downloaded file ' + inFileName + '!'); 383 | Except 384 | On E:Exception Do 385 | Begin 386 | // If the extracting failed, make sure to rename the file back to its original name 387 | // so it still can be accessed the next time the application starts 388 | Self.Rollback(inFileName); 389 | 390 | Raise; 391 | End; 392 | End; 393 | End; 394 | 395 | Function TAEUpdater.ChannelVisible(Const inChannel: TAEUpdaterChannel): Boolean; 396 | Begin 397 | // Developer channel should be able to see and update to production deployments if they are higher by version number 398 | 399 | Result := Integer(_channel) >= Integer(inChannel); 400 | End; 401 | 402 | End. 403 | -------------------------------------------------------------------------------- /AE.IDE/AE.IDE.VSVersions.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.IDE.VSVersions; 10 | 11 | Interface 12 | 13 | Uses AE.IDE.Versions, System.Classes, AE.DDEManager; 14 | 15 | Type 16 | TAEVSDDEManager = Class(TAEDDEManager) 17 | public 18 | Constructor Create(Const inVersion: Integer; Const inDiscoveryTimeout: Cardinal); ReIntroduce; 19 | End; 20 | 21 | TAEVSInstance = Class(TAEIDEInstance) 22 | strict private 23 | _versionnumber: Integer; 24 | strict protected 25 | Procedure InternalFindIDEWindow; Override; 26 | Procedure InternalOpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal = 5000); Override; 27 | public 28 | Constructor Create(inOwner: TComponent; Const inPID: Cardinal; Const inVersionNumber: Integer); ReIntroduce; 29 | End; 30 | 31 | TAEVSVersion = Class(TAEIDEVersion) 32 | strict private 33 | _ddediscoverytimeout: Cardinal; 34 | Procedure SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 35 | strict protected 36 | Function InternalGetName: String; Override; 37 | Procedure InternalRefreshInstances; Override; 38 | public 39 | Constructor Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer; Const inDDEDiscoveryTimeout: Cardinal); ReIntroduce; 40 | Property DDEDiscoveryTimeout: Cardinal Read _ddediscoverytimeout Write SetDDEDiscoveryTimeout; 41 | End; 42 | 43 | TAEVSVersions = Class(TAEIDEVersions) 44 | strict private 45 | _ddediscoverytimeout: Cardinal; 46 | _vswhere: String; 47 | Procedure AddFromRegistry; 48 | Procedure AddFromVSWhere; 49 | Procedure AddFromWMI; 50 | Procedure SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 51 | Procedure SetVSWhere(Const inVSWhereLocation: String); 52 | Function GetDOSOutput(Const inCommandLine: String): String; 53 | strict protected 54 | Procedure InternalRefreshInstalledVersions; Override; 55 | public 56 | Constructor Create(inOwner: TComponent); Override; 57 | Property DDEDiscoveryTimeout: Cardinal Read _ddediscoverytimeout Write SetDDEDiscoveryTimeout; 58 | Property VSWhereExeLocation: String Read _vswhere Write SetVSWhere; 59 | End; 60 | 61 | Implementation 62 | 63 | Uses Win.Registry, System.SysUtils, WinApi.Windows, System.JSON, AE.IDE.Versions.Consts, WinApi.ActiveX, System.Win.ComObj, System.Variants; 64 | 65 | Type 66 | PTOKEN_USER = ^TOKEN_USER; 67 | 68 | Function FindVSWindow(inHWND: HWND; inParam: LParam): Boolean; StdCall; 69 | Var 70 | ppid: Cardinal; 71 | title, classname: Array[0..255] Of Char; 72 | Begin 73 | // https://docs.microsoft.com/en-us/previous-versions/windows/desktop/legacy/ms633498(v=vs.85) 74 | // Result := True -> Continue evaluation 75 | // Result := False -> Do not continue evaluation 76 | 77 | GetWindowThreadProcessID(inHWND, ppid); 78 | GetWindowText(inHWND, title, 255); 79 | GetClassName(inHWND, classname, 255); 80 | 81 | Result := (ppid <> PAEIDEInfo(inParam)^.PID) Or Not IsWindowVisible(inHWND) Or Not IsWindowEnabled(inHWND) Or 82 | Not String(title).Contains('Microsoft Visual Studio') Or Not String(classname).StartsWith('HwndWrapper[DefaultDomain;;'); 83 | 84 | If Not Result Then 85 | Begin 86 | PAEIDEInfo(inParam)^.outHWND := inHWND; 87 | PAEIDEInfo(inParam)^.outWindowCaption := title; 88 | End; 89 | End; 90 | 91 | // 92 | // TAEVSDDEManager 93 | // 94 | 95 | Constructor TAEVSDDEManager.Create(const inVersion: Integer; Const inDiscoveryTimeout: Cardinal); 96 | Begin 97 | inherited Create('VisualStudio.' + inVersion.ToString + '.0', 'system', False, inDiscoveryTimeout); 98 | End; 99 | 100 | // 101 | // TAEVSInstance 102 | // 103 | 104 | Constructor TAEVSInstance.Create(inOwner: TComponent; Const inPID: Cardinal; Const inVersionNumber: Integer); 105 | Begin 106 | inherited Create(inOwner, inPID);; 107 | 108 | _versionnumber := inVersionNumber; 109 | End; 110 | 111 | Procedure TAEVSInstance.InternalFindIDEWindow; 112 | Var 113 | info: PAEIDEInfo; 114 | Begin 115 | inherited; 116 | 117 | New(info); 118 | Try 119 | info^.PID := Self.PID; 120 | info^.outHWND := 0; 121 | info^.outWindowCaption := ''; 122 | 123 | EnumWindows(@FindVSWindow, LParam(info)); 124 | 125 | SetIDEHWND(info^.outHWND); 126 | SetIDECaption(info^.outWindowCaption); 127 | Finally 128 | Dispose(info); 129 | End; 130 | End; 131 | 132 | Procedure TAEVSInstance.InternalOpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal); 133 | Var 134 | ddemgr: TAEVSDDEManager; 135 | Begin 136 | inherited; 137 | 138 | ddemgr := TAEVSDDEManager.Create(_versionnumber, (Self.Owner As TAEVSVersion).DDEDiscoveryTimeout); 139 | Try 140 | While Not ddemgr.ServerFound(Self.PID) Do 141 | Begin 142 | If Self.InternalAbortOpenFile Then 143 | Exit; 144 | 145 | Sleep(1000); 146 | ddemgr.RefreshServers; 147 | End; 148 | 149 | ddemgr.ExecuteCommand('[Open("' + inFileName + '")]', Self.PID, inTimeOutInMs); 150 | Finally 151 | FreeAndNil(ddemgr); 152 | End; 153 | End; 154 | 155 | // 156 | // TAEVSVersion 157 | // 158 | 159 | Constructor TAEVSVersion.Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer; Const inDDEDiscoveryTimeout: Cardinal); 160 | Begin 161 | inherited Create(inOwner, inExecutablePath, inVersionNumber); 162 | 163 | _ddediscoverytimeout := inDDEDiscoveryTimeout; 164 | End; 165 | 166 | Function TAEVSVersion.InternalGetName: String; 167 | Begin 168 | Case Round(Self.VersionNumber) Of 169 | 8: 170 | Result := IDEVER_VS2005; 171 | 9: 172 | Result := IDEVER_VS2008; 173 | 10: 174 | Result := IDEVER_VS2010; 175 | 11: 176 | Result := IDEVER_VS2012; 177 | 12: 178 | Result := IDEVER_VS2013; 179 | 14: 180 | Result := IDEVER_VS2015; 181 | 15: 182 | Result := IDEVER_VS2017; 183 | 16: 184 | Result := IDEVER_VS2019; 185 | 17: 186 | Result := IDEVER_VS2022; 187 | Else 188 | Result := 'Microsoft Visual Studio v' + Self.VersionNumber.ToString; 189 | End; 190 | End; 191 | 192 | Procedure TAEVSVersion.InternalRefreshInstances; 193 | Var 194 | ddemgr: TAEVSDDEManager; 195 | pid: Cardinal; 196 | Begin 197 | ddemgr := TAEVSDDEManager.Create(Self.VersionNumber, _ddediscoverytimeout); 198 | Try 199 | For pid In ddemgr.DDEServerPIDs Do 200 | If ProcessName(pid).ToLower = Self.ExecutablePath.ToLower Then 201 | Self.AddInstance(TAEVSInstance.Create(Self, pid, Self.VersionNumber)); 202 | Finally 203 | FreeAndNil(ddemgr); 204 | End; 205 | End; 206 | 207 | Procedure TAEVSVersion.SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 208 | Begin 209 | If inDDEDiscoveryTimeout = _ddediscoverytimeout Then 210 | Exit; 211 | 212 | _ddediscoverytimeout := inDDEDiscoveryTimeout; 213 | 214 | Self.RefreshInstances; 215 | End; 216 | 217 | // 218 | // TAEVSVersions 219 | // 220 | 221 | Procedure TAEVSVersions.AddFromRegistry; 222 | Var 223 | reg: TRegistry; 224 | sl: TStringList; 225 | s, loc: String; 226 | Begin 227 | sl := TStringList.Create; 228 | Try 229 | reg := TRegistry.Create(KEY_READ Or KEY_WOW64_64KEY); 230 | Try 231 | reg.RootKey := HKEY_LOCAL_MACHINE; 232 | 233 | If Not reg.OpenKey('SOFTWARE\WOW6432Node\Microsoft\VisualStudio\SxS\VS7', False) And 234 | Not reg.OpenKey('SOFTWARE\Microsoft\VisualStudio\SxS\VS7', False) Then 235 | Exit; 236 | 237 | Try 238 | reg.GetValueNames(sl); 239 | 240 | For s In sl Do 241 | Begin 242 | loc := IncludeTrailingPathDelimiter(reg.ReadString(s)) + 'Common7\IDE\devenv.exe'; 243 | If FileExists(loc) Then 244 | Self.AddVersion(TAEVSVersion.Create(Self, loc, Integer.Parse(s.Substring(0, s.IndexOf('.'))), _ddediscoverytimeout)); 245 | End; 246 | Finally 247 | reg.CloseKey; 248 | End; 249 | Finally 250 | FreeAndNil(reg); 251 | End; 252 | Finally 253 | FreeAndNil(sl); 254 | End; 255 | End; 256 | 257 | Procedure TAEVSVersions.AddFromVSWhere; 258 | Var 259 | json: TJSONArray; 260 | ver, loc: String; 261 | jv: TJSONValue; 262 | jo: TJSONObject; 263 | Begin 264 | {$IF CompilerVersion > 32} // Everything above 10.2...? 265 | json := TJSONArray(TJSONObject.ParseJSONValue(GetDOSOutput(_vswhere + ' -format json -legacy'), True, True)); 266 | {$ELSE} 267 | json := TJSONArray(TJSONObject.ParseJSONValue(GetDOSOutput(_vswhere + ' -format json -legacy'), True)); 268 | If Not Assigned(json) Then 269 | Raise EJSONException.Create('VSWhere.exe did not return a valid JSON document!'); 270 | {$ENDIF} 271 | 272 | Try 273 | For jv In json Do 274 | Begin 275 | jo := TJSONObject(jv); 276 | 277 | ver := jo.GetValue('installationVersion').Value; 278 | loc := jo.GetValue('productPath').Value; 279 | 280 | Self.AddVersion(TAEVSVersion.Create(Self, loc, Integer.Parse(ver.Substring(0, ver.IndexOf('.'))), _ddediscoverytimeout)); 281 | End; 282 | Finally 283 | FreeAndNil(json); 284 | End; 285 | End; 286 | 287 | Procedure TAEVSVersions.AddFromWMI; 288 | Var 289 | needuninit: Boolean; 290 | wbemlocator, wmiservice, objectset, wbemobject: OLEVariant; 291 | enum: IEnumvariant; 292 | value: LongWord; 293 | ver: String; 294 | Begin 295 | Case CoInitializeEx(nil, COINIT_MULTITHREADED) Of 296 | S_OK: 297 | needuninit := True; 298 | S_FALSE: 299 | needuninit := True; 300 | Else 301 | needuninit := False; 302 | End; 303 | 304 | Try 305 | Try 306 | wbemlocator := CreateOleObject('WbemScripting.SWbemLocator'); 307 | Try 308 | wmiservice := wbemlocator.ConnectServer('', 'root\cimv2', '', ''); 309 | Try 310 | objectset := wmiservice.ExecQuery('SELECT ProductLocation, Version from MSFT_VSInstance', 'WQL', 32); 311 | Try 312 | enum := IUnknown(objectset._NewEnum) As IEnumVariant; 313 | Try 314 | While enum.Next(1, wbemobject, value) = 0 Do 315 | Try 316 | If (wbemobject.ProductLocation <> null) And FileExists(wbemobject.ProductLocation) And (wbemobject.Version <> null) Then 317 | Begin 318 | ver := wbemobject.Version; 319 | 320 | Self.AddVersion(TAEVSVersion.Create(Self, wbemobject.ProductLocation, Integer.Parse(ver.Substring(0, ver.IndexOf('.'))), _ddediscoverytimeout)); 321 | End; 322 | Finally 323 | VarClear(wbemobject); 324 | End; 325 | Finally 326 | enum := nil; 327 | End; 328 | Finally 329 | VarClear(objectset); 330 | End; 331 | Finally 332 | VarClear(wmiservice); 333 | End; 334 | Finally 335 | VarClear(wbemlocator); 336 | End; 337 | Except 338 | On E:EOleException Do 339 | Begin 340 | // Swallowing exceptions is generally a bad idea. However, if the WMI provider is not installed an exception is thrown by the 341 | // WMI service. For us though, that doesn't mean an actual error; it's simply not supported. 342 | End 343 | Else 344 | Raise; 345 | End; 346 | Finally 347 | If needuninit Then 348 | CoUnInitialize; 349 | End; 350 | End; 351 | 352 | Constructor TAEVSVersions.Create(inOwner: TComponent); 353 | Begin 354 | inherited; 355 | 356 | _ddediscoverytimeout := 1; 357 | _vswhere := ''; 358 | End; 359 | 360 | Function TAEVSVersions.GetDOSOutput(Const inCommandLine: String): String; 361 | Const 362 | LOGON_WITH_PROFILE = $00000001; 363 | Var 364 | secattrib: TSecurityAttributes; 365 | startinfo: TStartupInfo; 366 | procinfo: TProcessInformation; 367 | piperead, pipewrite: THandle; 368 | buf: Array[0..1023] Of AnsiChar; 369 | a: Cardinal; 370 | Begin 371 | Result := ''; 372 | 373 | FillChar(secattrib, SizeOf(secattrib), 0); 374 | secattrib.nLength := SizeOf(secattrib); 375 | secattrib.bInheritHandle := True; 376 | secattrib.lpSecurityDescriptor := nil; 377 | CreatePipe(piperead, pipewrite, @secattrib, 0); 378 | Try 379 | FillChar(startinfo, SizeOf(startinfo), 0); 380 | startinfo.cb := SizeOf(startinfo); 381 | startinfo.dwFlags := STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES; 382 | startinfo.wShowWindow := SW_HIDE; 383 | startinfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect stdin 384 | startinfo.hStdOutput := pipewrite; 385 | startinfo.hStdError := pipewrite; 386 | 387 | Try 388 | If Not CreateProcess(nil, PChar(inCommandLine), nil, nil, True, CREATE_NEW_PROCESS_GROUP Or CREATE_NEW_CONSOLE, nil, nil, startinfo, procinfo) Then 389 | RaiseLastOSError; 390 | Finally 391 | // If this is not here, ReadFile might hang until infinity 392 | CloseHandle(pipewrite); 393 | End; 394 | 395 | Try 396 | Repeat 397 | If Not ReadFile(piperead, buf, Length(buf) - 1, a, nil) Then 398 | Begin 399 | a := GetLastError; 400 | 401 | // ERROR_BROKEN_PIPE means the process terminated and the pipe was closed 402 | If a = ERROR_BROKEN_PIPE Then 403 | Break; 404 | 405 | RaiseLastOSError(a); 406 | End; 407 | 408 | If a > 0 Then 409 | Begin 410 | buf[a] := #0; 411 | Result := Result + String(buf); 412 | End; 413 | Until (a = 0); 414 | 415 | Result := Result.Trim; 416 | Finally 417 | CloseHandle(procinfo.hThread); 418 | CloseHandle(procinfo.hProcess); 419 | End; 420 | Finally 421 | CloseHandle(piperead); 422 | End; 423 | End; 424 | 425 | Procedure TAEVSVersions.InternalRefreshInstalledVersions; 426 | Begin 427 | inherited; 428 | 429 | If Not _vswhere.IsEmpty Then 430 | Self.AddFromVSWhere; 431 | 432 | If Length(Self.InstalledVersions) = 0 Then 433 | Self.AddFromWMI; 434 | 435 | If Length(Self.InstalledVersions) = 0 Then 436 | Self.AddFromRegistry; 437 | End; 438 | 439 | Procedure TAEVSVersions.SetDDEDiscoveryTimeout(Const inDDEDiscoveryTimeout: Cardinal); 440 | Var 441 | ver: TAEIDEVersion; 442 | Begin 443 | If inDDEDiscoveryTimeout = _ddediscoverytimeout Then 444 | Exit; 445 | 446 | _ddediscoverytimeout := inDDEDiscoveryTimeout; 447 | 448 | For ver In Self.InstalledVersions Do 449 | (ver As TAEVSVersion).DDEDiscoveryTimeout := inDDEDiscoveryTimeout; 450 | End; 451 | 452 | Procedure TAEVSVersions.SetVSWhere(const inVSWhereLocation: String); 453 | Begin 454 | If _vswhere = inVSWhereLocation Then 455 | Exit; 456 | 457 | _vswhere := inVSWhereLocation; 458 | 459 | Self.RefreshInstalledVersions; 460 | End; 461 | 462 | End. 463 | -------------------------------------------------------------------------------- /AE.IDE/AE.IDE.Versions.pas: -------------------------------------------------------------------------------- 1 | { 2 | AE Framework © 2022 by Akos Eigler is licensed under CC BY 4.0. 3 | To view a copy of this license, visit http://creativecommons.org/licenses/by/4.0/ 4 | 5 | This license requires that reusers give credit to the creator. It allows reusers to distribute, remix, adapt, 6 | and build upon the material in any medium or format, even for commercial purposes. 7 | } 8 | 9 | Unit AE.IDE.Versions; 10 | 11 | Interface 12 | 13 | Uses System.Classes, WinApi.Windows, System.SysUtils, System.Generics.Collections; 14 | 15 | Type 16 | TAEIDEInstance = Class(TComponent) 17 | strict private 18 | _abortopenfile: Boolean; 19 | _idehwnd: HWND; 20 | _idecaption: String; 21 | _pid: Cardinal; 22 | Function GetName: String; 23 | strict protected 24 | Procedure InternalFindIDEWindow; Virtual; 25 | Procedure InternalOpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal = 5000); Virtual; 26 | Procedure SetIDECaption(Const inIDECaption: String); 27 | Procedure SetIDEHWND(Const inIDEHWND: HWND); 28 | Function InternalIsIDEBusy: Boolean; Virtual; 29 | Property InternalAbortOpenFile: Boolean Read _abortopenfile; 30 | public 31 | Constructor Create(inOwner: TComponent; Const inPID: Cardinal); ReIntroduce; Virtual; 32 | Procedure AbortOpenFile; 33 | Procedure OpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal = 5000); 34 | Procedure UpdateCaption; 35 | Function FindIdeWindow(Const inForceSearch: Boolean = False): Boolean; 36 | Function IsIDEBusy: Boolean; 37 | Property IDECaption: String Read _idecaption; 38 | Property IDEHWND: HWND Read _idehwnd; 39 | Property Name: String Read GetName; 40 | Property PID: Cardinal Read _pid; 41 | End; 42 | 43 | TAEIDEExecutableVersion = Class 44 | strict private 45 | _build: Word; 46 | _major: Word; 47 | _minor: Word; 48 | _release: Word; 49 | _string: String; 50 | public 51 | Constructor Create(Const inMajorVersion, inMinorVersion, inReleaseVersion, inBuildVersion: Word); ReIntroduce; 52 | Property AsString: String Read _string; 53 | Property Build: Word Read _build; 54 | Property Major: Word Read _major; 55 | Property Minor: Word Read _minor; 56 | Property Release: Word Read _release; 57 | End; 58 | 59 | TAEIDEVersion = Class(TComponent) 60 | strict private 61 | _abortnewinstance: Boolean; 62 | _edition: String; 63 | _executablepath: String; 64 | _executableversion: TAEIDEExecutableVersion; 65 | _instances: TObjectList; 66 | _name: String; 67 | _versionnumber: Integer; 68 | Function GetInstances: TArray; 69 | strict protected 70 | Procedure AddInstance(Const inInstance: TAEIDEInstance); 71 | Procedure InternalRefreshInstances; Virtual; 72 | Function InternalGetEdition: String; Virtual; 73 | Function InternalGetExecutableVersion: TAEIDEExecutableVersion; Virtual; 74 | Function InternalGetName: String; Virtual; 75 | Function InternalNewIDEInstance(Const inParams: String): Cardinal; Virtual; 76 | Function ProcessName(Const inPID: Cardinal): String; 77 | public 78 | Constructor Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer); ReIntroduce; Virtual; 79 | Destructor Destroy; Override; 80 | Procedure AbortNewInstance; 81 | Procedure AfterConstruction; Override; 82 | Procedure RefreshInstances; 83 | Function InstanceByPID(Const inPID: Cardinal): TAEIDEInstance; 84 | Function IsRunning: Boolean; 85 | Function NewIDEInstance(Const inParams: String = ''): TAEIDEInstance; 86 | Property Edition: String Read _edition; 87 | Property ExecutablePath: String Read _executablepath; 88 | Property ExecutableVersion: TAEIDEExecutableVersion Read _executableversion; 89 | Property Instances: TArray Read GetInstances; 90 | Property Name: String Read _name; 91 | Property VersionNumber: Integer Read _versionnumber; 92 | End; 93 | 94 | TAEIDEVersions = Class(TComponent) 95 | strict private 96 | _latestversion: TAEIDEVersion; 97 | _versions: TObjectList; 98 | Function GetInstalledVersions: TArray; 99 | strict protected 100 | Procedure AddVersion(Const inVersion: TAEIDEVersion); 101 | Procedure InternalRefreshInstalledVersions; Virtual; 102 | public 103 | Constructor Create(inOwner: TComponent); Override; 104 | Destructor Destroy; Override; 105 | Procedure AfterConstruction; Override; 106 | Procedure RefreshInstalledVersions; 107 | Function VersionByName(Const inName: String): TAEIDEVersion; 108 | Function VersionByVersionNumber(Const inVersionNumber: Integer): TAEIDEVersion; 109 | Property LatestVersion: TAEIDEVersion Read _latestversion; 110 | Property InstalledVersions: TArray Read GetInstalledVersions; 111 | End; 112 | 113 | EAEIDEVersionException = Class(Exception); 114 | 115 | TAEIDEInfo = Record 116 | outHWND: HWND; 117 | outWindowCaption: String; 118 | PID: Cardinal; 119 | End; 120 | PAEIDEInfo = ^TAEIDEInfo; 121 | 122 | Implementation 123 | 124 | Uses WinApi.Messages, WinApi.PsAPI, AE.Misc.FileUtils; 125 | 126 | // 127 | // TDelphiInstance 128 | // 129 | 130 | Procedure TAEIDEInstance.AbortOpenFile; 131 | Begin 132 | _abortopenfile := True; 133 | End; 134 | 135 | Constructor TAEIDEInstance.Create(inOwner: TComponent; Const inPID: Cardinal); 136 | Begin 137 | inherited Create(inOwner); 138 | 139 | _abortopenfile := False; 140 | _idehwnd := 0; 141 | _idecaption := ''; 142 | _pid := inPID; 143 | 144 | FindIdeWindow; 145 | End; 146 | 147 | Function TAEIDEInstance.FindIdeWindow(const inForceSearch: Boolean): Boolean; 148 | Begin 149 | If Not inForceSearch And (_idehwnd <> 0) And IsWindow(_idehwnd) Then 150 | Begin 151 | // IDE window was already found and seems to be still valid 152 | 153 | Result := True; 154 | Exit; 155 | End; 156 | 157 | _idehwnd := 0; 158 | _idecaption := ''; 159 | 160 | Self.InternalFindIDEWindow; 161 | 162 | Result := _idehwnd <> 0; 163 | End; 164 | 165 | Function TAEIDEInstance.GetName: String; 166 | Begin 167 | If _idecaption.IsEmpty Then 168 | Result := (Self.Owner As TAEIDEVersion).Name + ' (PID: ' + _pid.ToString + ')' 169 | Else 170 | Result := _idecaption + ' (PID: ' + _pid.ToString + ')'; 171 | End; 172 | 173 | Procedure TAEIDEInstance.InternalFindIDEWindow; 174 | Begin 175 | // Dummy 176 | End; 177 | 178 | Function TAEIDEInstance.InternalIsIDEBusy: Boolean; 179 | Var 180 | res: NativeInt; 181 | Begin 182 | If Not FindIdeWindow Then 183 | Raise EAEIDEVersionException.Create('Delphi IDE window can not be found!'); 184 | 185 | Result := Not IsWindowVisible(_idehwnd); 186 | 187 | If Result Then 188 | Exit; 189 | 190 | Result := SendMessageTimeout(_idehwnd, WM_NULL, 0, 0, SMTO_BLOCK, 250, nil) = 0; 191 | 192 | If Not Result Then 193 | Exit; 194 | 195 | res := GetLastError; 196 | 197 | If res <> ERROR_TIMEOUT Then 198 | RaiseLastOSError(res); 199 | End; 200 | 201 | Procedure TAEIDEInstance.InternalOpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal); 202 | Begin 203 | // Dummy 204 | End; 205 | 206 | Function TAEIDEInstance.IsIDEBusy: Boolean; 207 | Begin 208 | Result := Self.InternalIsIDEBusy; 209 | End; 210 | 211 | Procedure TAEIDEInstance.OpenFile(Const inFileName: String; Const inTimeOutInMs: Cardinal); 212 | Begin 213 | _abortopenfile := False; 214 | 215 | Self.InternalOpenFile(inFileName, inTimeOutInMs); 216 | End; 217 | 218 | Procedure TAEIDEInstance.SetIDECaption(Const inIDECaption: String); 219 | Begin 220 | _idecaption := inIDECaption; 221 | End; 222 | 223 | Procedure TAEIDEInstance.SetIDEHWND(Const inIDEHWND: HWND); 224 | Begin 225 | _idehwnd := inIDEHWND; 226 | End; 227 | 228 | Procedure TAEIDEInstance.UpdateCaption; 229 | Var 230 | title: Array[0..255] Of Char; 231 | Begin 232 | If Not FindIdeWindow Then 233 | Raise EAEIDEVersionException.Create('Delphi IDE window can not be found!'); 234 | 235 | GetWindowText(_idehwnd, title, 255); 236 | 237 | _idecaption := title; 238 | End; 239 | 240 | // 241 | // TAEExecutableVersion 242 | // 243 | 244 | Constructor TAEIDEExecutableVersion.Create(Const inMajorVersion, inMinorVersion, inReleaseVersion, inBuildVersion: Word); 245 | Begin 246 | _build := inBuildVersion; 247 | _major := inMajorVersion; 248 | _minor := inMinorVersion; 249 | _release := inReleaseVersion; 250 | _string := Format('%d.%d.%d.%d', [_major, _minor, _release, _build]); 251 | End; 252 | 253 | // 254 | // TIDEVersion 255 | // 256 | 257 | Procedure TAEIDEVersion.AbortNewInstance; 258 | Begin 259 | _abortnewinstance := True; 260 | End; 261 | 262 | Procedure TAEIDEVersion.AddInstance(Const inInstance: TAEIDEInstance); 263 | Begin 264 | _instances.Add(inInstance); 265 | End; 266 | 267 | Procedure TAEIDEVersion.AfterConstruction; 268 | Begin 269 | inherited; 270 | 271 | _edition := Self.InternalGetEdition; 272 | _executableversion := Self.InternalGetExecutableVersion; 273 | _name := Self.InternalGetName; 274 | 275 | If _name.IsEmpty Then 276 | _name := 'IDE v' + _versionnumber.ToString; 277 | 278 | Self.RefreshInstances; 279 | End; 280 | 281 | Constructor TAEIDEVersion.Create(inOwner: TComponent; Const inExecutablePath: String; Const inVersionNumber: Integer); 282 | Begin 283 | inherited Create(inOwner); 284 | 285 | _abortnewinstance := False; 286 | _edition := ''; 287 | _executablepath := inExecutablePath.Trim; 288 | _executableversion := nil; 289 | _instances := TObjectList.Create(True); 290 | _name := ''; 291 | _versionnumber := inVersionNumber; 292 | End; 293 | 294 | Destructor TAEIDEVersion.Destroy; 295 | Begin 296 | FreeAndNil(_instances); 297 | FreeAndNil(_executableversion); 298 | 299 | inherited; 300 | End; 301 | 302 | Function TAEIDEVersion.GetInstances: TArray; 303 | Begin 304 | Result := _instances.ToArray; 305 | End; 306 | 307 | Function TAEIDEVersion.InstanceByPID(Const inPID: Cardinal): TAEIDEInstance; 308 | Var 309 | inst: TAEIDEInstance; 310 | Begin 311 | Result := nil; 312 | 313 | For inst In _instances Do 314 | If inst.PID = inPID Then 315 | Begin 316 | Result := inst; 317 | Break; 318 | End; 319 | End; 320 | 321 | Procedure TAEIDEVersion.InternalRefreshInstances; 322 | Begin 323 | // Dummy 324 | End; 325 | 326 | Function TAEIDEVersion.InternalGetEdition: String; 327 | Begin 328 | Result := ''; 329 | End; 330 | 331 | Function TAEIDEVersion.InternalGetExecutableVersion: TAEIDEExecutableVersion; 332 | Var 333 | fver: TFileVersion; 334 | Begin 335 | fver := FileVersion(Self.ExecutablePath); 336 | 337 | Result := TAEIDEExecutableVersion.Create(fver.MajorVersion, fver.MinorVersion, fver.ReleaseVersion, fver.BuildNumber); 338 | End; 339 | 340 | Function TAEIDEVersion.InternalGetName: String; 341 | Begin 342 | // Dummy 343 | 344 | Result := ''; 345 | End; 346 | 347 | Function TAEIDEVersion.InternalNewIDEInstance(Const inParams: String): Cardinal; 348 | Var 349 | startinfo: TStartupInfo; 350 | procinfo: TProcessInformation; 351 | cmd: String; 352 | Begin 353 | FillChar(startinfo, SizeOf(TStartupInfo), #0); 354 | startinfo.cb := SizeOf(TStartupInfo); 355 | FillChar(procinfo, SizeOf(TProcessInformation), #0); 356 | 357 | cmd := Self.ExecutablePath; 358 | 359 | If Not cmd.StartsWith('"') Then 360 | cmd := '"' + cmd; 361 | 362 | If Not cmd.EndsWith('"') Then 363 | cmd := cmd + '"'; 364 | 365 | If Not inParams.IsEmpty Then 366 | cmd := cmd + ' ' + inParams; 367 | 368 | If Not CreateProcess(nil, PChar(cmd), nil, nil, False, CREATE_NEW_PROCESS_GROUP, nil, nil, startinfo, procinfo) Then 369 | RaiseLastOSError; 370 | 371 | Try 372 | WaitForInputIdle(procinfo.hProcess, INFINITE); 373 | 374 | Result := procinfo.dwProcessId; 375 | Finally 376 | CloseHandle(procinfo.hThread); 377 | CloseHandle(procinfo.hProcess); 378 | End; 379 | End; 380 | 381 | Function TAEIDEVersion.IsRunning: Boolean; 382 | Begin 383 | Result := _instances.Count > 0; 384 | End; 385 | 386 | Function TAEIDEVersion.NewIDEInstance(Const inParams: String = ''): TAEIDEInstance; 387 | Var 388 | newpid: Cardinal; 389 | Begin 390 | _abortnewinstance := False; 391 | 392 | newpid := Self.InternalNewIDEInstance(inParams); 393 | 394 | Result := nil; 395 | Repeat 396 | If _abortnewinstance Then 397 | Exit; 398 | 399 | Result := Self.InstanceByPID(newpid); 400 | 401 | If Not Assigned(Result) Then 402 | Begin 403 | Sleep(1000); 404 | 405 | Self.RefreshInstances; 406 | End; 407 | Until Assigned(Result) And Result.FindIdeWindow And Not Result.IsIDEBusy; 408 | End; 409 | 410 | Function TAEIDEVersion.ProcessName(Const inPID: Cardinal): String; 411 | Var 412 | processhandle: THandle; 413 | Begin 414 | processhandle := OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, False, inPID); 415 | If processhandle = 0 Then 416 | RaiseLastOSError; 417 | 418 | Try 419 | SetLength(Result, MAX_PATH); 420 | FillChar(Result[1], Length(Result) * SizeOf(Char), 0); 421 | If GetModuleFileNameEx(processhandle, 0, PChar(Result), Length(Result)) = 0 Then 422 | RaiseLastOSError; 423 | 424 | Result := Trim(Result); 425 | Finally 426 | CloseHandle(processhandle) 427 | End; 428 | End; 429 | 430 | Procedure TAEIDEVersion.RefreshInstances; 431 | Begin 432 | _instances.Clear; 433 | 434 | Self.InternalRefreshInstances; 435 | End; 436 | 437 | // 438 | // TIDEVersions 439 | // 440 | 441 | Procedure TAEIDEVersions.AddVersion(Const inVersion: TAEIDEVersion); 442 | Begin 443 | _versions.Add(inVersion); 444 | 445 | If Not Assigned(_latestversion) Or (inVersion.VersionNumber > _latestversion.VersionNumber) Then 446 | _latestversion := inVersion; 447 | End; 448 | 449 | Procedure TAEIDEVersions.AfterConstruction; 450 | Begin 451 | inherited; 452 | 453 | Self.RefreshInstalledVersions; 454 | End; 455 | 456 | Constructor TAEIDEVersions.Create(inOwner: TComponent); 457 | Begin 458 | inherited; 459 | 460 | _latestversion := nil; 461 | _versions := TObjectList.Create(True); 462 | End; 463 | 464 | Destructor TAEIDEVersions.Destroy; 465 | Begin 466 | FreeAndNil(_versions); 467 | 468 | inherited; 469 | End; 470 | 471 | Function TAEIDEVersions.GetInstalledVersions: TArray; 472 | Begin 473 | Result := _versions.ToArray; 474 | End; 475 | 476 | Procedure TAEIDEVersions.InternalRefreshInstalledVersions; 477 | Begin 478 | // Dummy 479 | End; 480 | 481 | Procedure TAEIDEVersions.RefreshInstalledVersions; 482 | begin 483 | _versions.Clear; 484 | 485 | Self.InternalRefreshInstalledVersions; 486 | End; 487 | 488 | Function TAEIDEVersions.VersionByName(Const inName: String): TAEIDEVersion; 489 | Begin 490 | For Result In _versions Do 491 | If Result.Name = inName Then 492 | Exit; 493 | 494 | Result := nil; 495 | End; 496 | 497 | Function TAEIDEVersions.VersionByVersionNumber(Const inVersionNumber: Integer): TAEIDEVersion; 498 | Begin 499 | For Result In _versions Do 500 | If Result.VersionNumber = inVersionNumber Then 501 | Exit; 502 | 503 | Result := nil; 504 | End; 505 | 506 | End. 507 | --------------------------------------------------------------------------------