From d3bfcc88d6c22c85e02a1e1555dd4874369adb53 Mon Sep 17 00:00:00 2001 From: TomBuz Date: Sun, 28 Sep 2025 13:58:51 +0200 Subject: [PATCH] Prvni verze pred predanim (nove soubor empUtils.pas) --- empUtils.pas | 4834 ++++++++++++++++++++++++++++++++++++++++++++++++++ frmKeyb.pas | 18 +- 2 files changed, 4850 insertions(+), 2 deletions(-) create mode 100644 empUtils.pas diff --git a/empUtils.pas b/empUtils.pas new file mode 100644 index 0000000..ef06ebc --- /dev/null +++ b/empUtils.pas @@ -0,0 +1,4834 @@ +unit empUtils; + +interface + +uses Winapi.Windows, SysUtils, Winapi.wtsApi32 , System.Classes, Vcl.Forms, Vcl.Controls, Vcl.StdCtrls, Vcl.ImgList, Vcl.Grids, + System.SysConst, System.RTLConsts, System.MaskUtils, Vcl.ExtCtrls, FireDAC.Comp.Client, ddPlugin_TLB, Winapi.TlHelp32, + Vcl.ComCtrls, IdURI, Vcl.Graphics, System.Generics.Collections, System.Generics.Defaults, Winapi.WinSvc, Winapi.WinSock, + System.SyncObjs, Winapi.Messages; + +const + CRLF = #13#10; + focCol = $F0CAA6; // clSkyBlue; + HARD_SPACE = Chr(160); + CSIDL_PROFILE = $0028; { USERPROFILE } + + WM_UPDATE_PROGRESS = WM_USER + 100; // custom message ve waitStart2 + + HS_Caramel = 1; + HS_Foggy = 2; + HS_iMaginary = 3; + HS_Metrolpolis = 4; + HS_Springtime = 5; + HS_Office2016Col = 6; + HS_Office2016Dark = 7; + HS_HighContrast = 8; + HS_Xmas2008Blue = 9; + HS_Summer2008 = 10; + HS_Valentine = 11; + HS_HeliosASol = 12; + HS_HeliosOrangeLight = 13; + HS_HeliosOrange = 14; + HS_HeliosEasy = 15; + HS_HeliosGreen = 16; + HS_Pumpkin = 17; + + + + bidTabExtKom = 541; // #TabExtKom + + bidCisOrg = 1; // TabCisOrg + bidKZ = 2; + bidStrom = 4; + bidDok = 5; // TabDokumenty + bidSS = 8; // Stav skladu + bidSZ = 15; // TabSkupinyZbozi + bidDZPrij = 16; // Prijemky + bidDZVydej = 18; // Vydejky + bidExpPr = 25; // Exp. prikazy + bidNabid = 27; // Nabidky + bidDDZ = 34; // TabDruhDokZTbo + bidPZ = 45; // Pohyby zbozi pres editaci dokladu + bidVyrCP58 = 58; // vyber z vyrobnich cisel nad kmenem "Vyrobni cisla vybranych karet" + bidPZ_F9 = 74; // Pohyby zbozi pres F9 + bidVyrCS75 = 75; // TabVyrCS + bidVyrCP76 = 76; // TabVyrCP + bidCisNC = 51; // TabCisNC + bidSUKod = 56; // TabSkupUKod + bidKOs = 115; // TabCisKOs + bidKList = 62; + bidCisZam = 86; // Ciselnik zamestnancu + bidUkoly = 240; + bidKategUk = 1117; + bidDilce = 11001; // vyrabene dilce + bidMaterialy = 11002; // nakupovane materialy + bidVyrPlan = 11010; // vyrobni plan + bidVyrPrik = 11011; // Vyrobni prikazy + bidVyrPrikVC = 11083; // Vyrobni cisla na prikaze + bidVyrCisKm = 1978; // kmen vyrobniho cisla + bidVyrCisStav = 75; + bidFrontaPrace = 11109; + bidZavady = 11015; + bidPrKVaz = 11050; + bidVyrOper = 11051; + bidEvidOp = 11122; + bidPrPostupy = 11074; + bidPostup = 11019; + bidTpvOPN = 11174; + bidVyrDokum = 11339; + bidCisOPN = 11128; + bidCisKoop = 11005; + + bidQMSReklPrij = 1671; + bidQMSReklPrijStavy = 1678; + + bidQMSReklVyd = 1681; + bidQMSReklVydStavy = 1684; + + bidQMSUkoly = 1696; + bidQMSKateg = 1650; + bidQMSKategUkol = 1670; + + bidQMSMeridlaStavy = 1652; + bidQMSMeridlaDruhy = 1653; + bidQMSMeridlaKateg = 1654; + + bidQMSZarizStavy = 1657; + bidQMSZarizDruhy = 1658; + + bidFV = 29; // vydane faktury + bidFP = 134; // prijate faktury + bidCSmen = 11293; // ciselnik smen + bidZak = 59; // Zakazky + bidRadyZak = 1386; // Rady zakazek + bidUmisteni = 542; + bidMzdObd = 200; // TabMzdObd + bidPoklDokl = 84; // pokladni doklady + bidMaPrZa = 247; // protokoly zavedeni + bidMaKar = 144; // karty majetku + + bidDObjR02 = 962; // F9 - TabDosleObjR02 - polozky dosle objednavky + bidDObjR02_F9 = 974; // F9 - TabDosleObjR02 - polozky dosle objednavky + + + tblErrSQL = '[dbo].[_TabSQLErr]'; + tblLastSet = '[dbo].[TabLastSetting]'; + + + tblMailProfil = '[dbo].[TabEMailProfil]'; + + tblHGlob = '[dbo].[TabHGlob]'; + tblUzivOzn = '[dbo].[TabUzivOzn]'; + tblExtKom = '[dbo].[TabExtKom]'; + tblExtKomPar = '[dbo].[TabExtKomPar]'; + tblDefZprav = '[dbo].[TabDefZprav]'; + tblZpravy = '[dbo].[TabZpravy]'; + tblFormDef = '[dbo].[TabFormDef]'; + tblTiskDef = '[dbo].[TabDefTisk]'; + + tblPravaSklad = '[dbo].[TabPravaSklad]'; + tblRole = '[dbo].[TabRole]'; + tblUziv = '[dbo].[TabUziv]'; + tblUserCfg = '[dbo].[TabUserCfg]'; + tblPlgInfo = '[dbo].[TabPluginInfo]'; + tblObecPrehled = '[dbo].[TabObecnyPrehled]'; + tblFiltr = '[dbo].[TabFiltr]'; + tblUzivAtr = '[dbo].[TabUzivAtr]'; + tblZmenLog = '[dbo].[TabZmenovyLOG]'; + tblZurnal = '[dbo].[TabZurnal]'; + + tblMaPrZa = '[dbo].[TabMaPrZa]'; + tblMaKar = '[dbo].[TabMaKar]'; + + tblInvH = '[dbo].[TabInvHead]'; + tblInvI = '[dbo].[TabInvItem]'; + tblDDZ = '[dbo].[TabDruhDokZbo]'; + tblDDZe = '[dbo].[TabDruhDokZbo_EXT]'; + tblDZDod = '[dbo].[TabDokZboDodatek]'; + tblDDZdef = '[dbo].[TabDruhDokZboDef]'; + tblDZ = '[dbo].[TabDokladyZbozi]'; + tblDZe = '[dbo].[TabDokladyZbozi_EXT]'; + tblPZ = '[dbo].[TabPohybyZbozi]'; + tblPZe = '[dbo].[TabPohybyZbozi_EXT]'; + tblTxtPol = '[dbo].[TabOZTxtPol]'; + tblTxtPolE = '[dbo].[TabOZTxtPol_EXT]'; + tblKZ = '[dbo].[TabKmenZbozi]'; + tblKZe = '[dbo].[TabKmenZbozi_EXT]'; + tblKZDod = '[dbo].[TabKmenZboziDodatek]'; + tblSortim = '[dbo].[TabSortiment]'; + tblSortimE = '[dbo].[TabSortiment_EXT]'; + tblDodavateleZbozi = '[dbo].[TabZboziDodavatel]'; + tblDodavateleZboziE = '[dbo].[TabZboziDodavatel_EXT]'; + tblMJ = '[dbo].[TabMJ]'; + tblMJZbo = '[dbo].[TabMJZbozi]'; + tblOZSumCen = '[dbo].[TabOZSumaceCen]'; + + + tblParKZ = '[dbo].[TabParKmZ]'; + tblParamKZ = '[dbo].[TabParametryKmeneZbozi]'; + tblSZ = '[dbo].[TabSkupinyZbozi]'; + tblSZe = '[dbo].[TabSkupinyZbozi_EXT]'; + tblSS = '[dbo].[TabStavSkladu]'; + tblSSE = '[dbo].[TabStavSkladu_EXT]'; + tblVyrCK = '[dbo].[TabVyrCK]'; + tblVyrCKE = '[dbo].[TabVyrCK_EXT]'; + tblVyrCS = '[dbo].[TabVyrCS]'; + tblVyrCSE = '[dbo].[TabVyrCS_EXT]'; + tblVyrCP = '[dbo].[TabVyrCP]'; + tblVyrCPE = '[dbo].[TabVyrCP_EXT]'; + tblCOrg = '[dbo].[TabCisOrg]'; + tblCOrgE = '[dbo].[TabCisOrg_EXT]'; + tblCZam = '[dbo].[TabCisZam]'; + tblCisZam = '[dbo].[TabCisZam]'; + tblCZamE = '[dbo].[TabCisZam_EXT]'; + tblCisZamE = '[dbo].[TabCisZam_EXT]'; + tblStrom = '[dbo].[TabStrom]'; + tblStromE = '[dbo].[TabStrom_EXT]'; + tblJC = '[dbo].[TabJC]'; + tblCisNC = '[dbo].[TabCisNC]'; + tblNC = '[dbo].[TabNC]'; + tblNCe = '[dbo].[TabNC_EXT]'; + tblNCImp = '[dbo].[TabNCImp]'; + tblNCCis = '[dbo].[TabCisNC]'; + tblKList = '[dbo].[TabKurzList]'; + tblMzSloz = '[dbo].[TabMzSloz]'; + tblPredzpr = '[dbo].[TabPredzp]'; + tblZamMzd = '[dbo].[TabZamMzd]'; + tblZamMzdE = '[dbo].[TabZamMzd_EXT]'; + tlbZamVyp = '[dbo].[TabZamVyp]'; + tblMzdObd = '[dbo].[TabMzdObd]'; + tblSazbyDPH = '[dbo].[TabSazbyDPH]'; + tblSazbyDPHZbo = '[dbo].[TabSazbyDPHZbo]'; + tblDPH = '[dbo].[TabDPH]'; + tblDPHDef = '[dbo].[TabDPHDef]'; + tblObd = '[dbo].[TabObdobi]'; + tblPSC = '[dbo].[TabPSC]'; + tblZeme = '[dbo].[TabZeme]'; + tblZemeE = '[dbo].[TabZeme_EXT]'; + tblBVrad = '[dbo].[TabBankVypisR]'; + tblPokl = '[dbo].[TabPokladna]'; + tblPoklP = '[dbo].[TabPolozkyPokl]'; + tblKOs = '[dbo].[TabCisKOs]'; + tblKOsE = '[dbo].[TabCisKOs_EXT]'; + tblPPlan = '[dbo].[TabZadVyp]'; + tblPPlanE = '[dbo].[TabZadVyp_EXT]'; + tblPPlanImp = '[dbo].[TabZadVypImp]'; + tblStruktKus = '[dbo].[TabStrukKusovZV]'; + tblKJ = '[dbo].[TabKontaktJednani]'; + tblKJE = '[dbo].[TabKontaktJednani_EXT]'; + tblKJPozn = '[dbo].[TabPoznKontJed]'; + tblKJZam = '[dbo].[TabKJUcastZam]'; + tblKJOrg = '[dbo].[TabKJUcastOrg]'; + tblKontakt = '[dbo].[TabKontakty]'; + tblKontOrgKOs = '[dbo].[TabVztahOrgKOs]'; + tblCZmen = '[dbo].[TabCzmeny]'; + tblZaklKalk = '[dbo].[TabZKalkulace]'; + tblKalkCe = '[dbo].[TabKalkCe]'; + tblCisOPN = '[dbo].[TabCisOPN]'; + tblTpvOPN = '[dbo].[TabTpvOPN]'; + tblZak = '[dbo].[TabZakazka]'; + tblZakE = '[dbo].[TabZakazka_EXT]'; + tblRadyZak = '[dbo].[TabZakazkaRada]'; + tblKUKod = '[dbo].[TabSkupUKod]'; + tblBCode = '[dbo].[TabBarCodeZbo]'; + tblVStin = '[dbo].[TabVStin]'; + tblCUct = '[dbo].[TabCisUct]'; + tblCUctE = '[dbo].[TabCisUct_EXT]'; + tblUkoly = '[dbo].[TabUkoly]'; + tblUkolyE = '[dbo].[TabUkoly_EXT]'; + tblKatUk = '[dbo].[TabKategUkoly]'; + tblPlnUk = '[dbo].[TabDosleObjH20]'; + tblPlnUkE = '[dbo].[TabDosleObjH20_EXT]'; + tblDokum = '[dbo].[TabDokumenty]'; + tblDokumE = '[dbo].[TabDokumenty_EXT]'; + tblDokumStr = '[dbo].[TabDokumStrom]'; + tblDokumStrom = '[dbo].[TabDokumStrom]'; + tblDokumStromE = '[dbo].[TabDokumStrom_EXT]'; + tblDokumVaz = '[dbo].[TabDokumVazba]'; + tblZamDopl = '[dbo].[TabZamPer]'; + tblZamDoplE = '[dbo].[TabZamPer_EXT]'; + tblVyrPerZdr = '[dbo].[TabVyrPerZdroje]'; + tblProfes = '[dbo].[TabProfes]'; + tblBSpoj = '[dbo].[TabBankSpojeni]'; + tblPUstavy = '[dbo].[TabPenezniUstavy]'; + tblPlanKal = '[dbo].[TabPlanKalendare]'; + tblPlanKalPol = '[dbo].[TabPlanKalendPol]'; + tblPlanKalPolE = '[dbo].[TabPlanKalendPol_EXT]'; + tblUmisteni = '[dbo].[TabUmisteni]'; + tblStavUmisteni = '[dbo].[TabVStavUmisteni]'; + tblUctenkaH = '[dbo].[TabUctenkaH]'; + tblUctenkaR = '[dbo].[TabUctenkaR]'; + tblfrmUhrady = '[dbo].[TabFormaUhrady]'; + tblfrmUhradyE = '[dbo].[TabFormaUhrady_EXT]'; + + tblKodMen = '[dbo].[TabKodMen]'; + tblKodMenE = '[dbo].[TabKodMen_EXT]'; + + tblSoz = '[dbo].[TabSoz]'; + tblSozNa = '[dbo].[TabSozNa]'; + + tblDObjR02 = '[dbo].[TabDosleObjR02]'; + tblDObjR02E = '[dbo].[TabDosleObjR02_EXT]'; + tblDObjH02 = '[dbo].[TabDosleObjH02]'; + tblDObjH02E = '[dbo].[TabDosleObjH02_EXT]'; + + tblDenik = '[dbo].[TabDenik]'; + tblDenikE = '[dbo].[TabDenik_EXT]'; + tblDenikImp = '[dbo].[TabDenikImp]'; + tblDenikImpE = '[dbo].[TabDenikImp_EXT]'; + tblStruktImpDen = '[dbo].[TabStrukturaImpDen]'; + + tblRozpRez = '[dbo].[TabFIARozpusteniRezii]'; + tblPreuctRez = '[dbo].[TabFIAPreuctovaniRezii]'; + tblRozpRezDet = '[dbo].[TabFIARozpusteniReziiDetail]'; + tblRozpRezDetVst = '[dbo].[TabFIARozpusteniReziiDetailVstup]'; + + tblPlan = '[dbo].[TabPlan]'; + tblPlanE = '[dbo].[TabPlan_EXT]'; + tblPrikaz = '[dbo].[TabPrikaz]'; + tblPrikazE = '[dbo].[TabPrikaz_EXT]'; + tblVPr = '[dbo].[TabPrikaz]'; + tblVPrE = '[dbo].[TabPrikaz_EXT]'; + tblPrikazRada = '[dbo].[TabRadyPrikazu]'; + tblPrikazRadaE = '[dbo].[TabRadyPrikazu_EXT]'; + tblPrikazVC = '[dbo].[TabVyrCisPrikaz]'; + tblPrikazVCE = '[dbo].[TabVyrCisPrikaz_EXT]'; + + tblKVaz = '[dbo].[TabKVazby]'; + tblKVazE = '[dbo].[TabKVazby_EXT]'; + tblKVazImp = '[dbo].[TabKVazbyImp]'; + tblPostup = '[dbo].[TabPostup]'; + tblPostupE = '[dbo].[TabPostup_EXT]'; + tblPrVaz = '[dbo].[TabPrKVazby]'; + tblPrVazE = '[dbo].[TabPrKVazby_EXT]'; + tblPrKVaz = '[dbo].[TabPrKVazby]'; + tblPrKVazE = '[dbo].[TabPrKVazby_EXT]'; + tblPrPost = '[dbo].[TabPrPostup]'; + tblPrPostE = '[dbo].[TabPrPostup_EXT]'; + tblPrNVazby = '[dbo].[TabPrNVazby]'; + tblPrNVazbyE = '[dbo].[TabPrNVazby_EXT]'; + tblPrVazVC = '[dbo].[TabVyrCisPrKV]'; + + tblAlterKZ = '[dbo].[TabAlterKZ]'; + tblKObj = '[dbo].[TabKoopObj]'; + tblPKObj = '[dbo].[TabPolKoopObj]'; + tblMzdZm = '[dbo].[TabPrikazMzdyAZmetky]'; + tblPMZ = '[dbo].[TabPrikazMzdyAZmetky]'; + tblMzdZmE = '[dbo].[TabPrikazMzdyAZmetky_EXT]'; + tblPMZE = '[dbo].[TabPrikazMzdyAZmetky_EXT]'; + tblMzdZmGenPZ = '[dbo].[TabPrikazMzdyAZmetkyGenPZ]'; + tblPMZGenPZ = '[dbo].[TabPrikazMzdyAZmetkyGenPZ]'; + tblMzdZavady = '[dbo].[TabPrikazMzdyAZmetkyRozpisZavad]'; + tblPMZZavady = '[dbo].[TabPrikazMzdyAZmetkyRozpisZavad]'; + tblZavady = '[dbo].[TabCZavad]'; + tblCZavad = '[dbo].[TabCZavad]'; + tblCZavadE = '[dbo].[TabCZavad_EXT]'; + + tblPrikazPlan = '[dbo].[TabPrikazZdrojVyrPlan]'; + tblPrikazZdrojOZ = '[dbo].[TabPrikazZdrojOZ]'; + + tblZakazModif = '[dbo].[TabZakazModif]'; + tblZakazModifE = '[dbo].[TabZakazModif_EXT]'; + tblZakazModifDilce = '[dbo].[TabZakazModifDilce]'; + + tblTar = '[dbo].[TabTarP]'; + tblTarH = '[dbo].[TabTarH]'; + tblCPrac = '[dbo].[TabCPraco]'; + tblCPracE = '[dbo].[TabCPraco_EXT]'; + tblCSmen = '[dbo].[TabCSmeny]'; + tblCStroju = '[dbo].[TabCisStroju]'; + tblCStrojuE = '[dbo].[TabCisStroju_EXT]'; + tblPredna = '[dbo].[TabPredna]'; + tblPrednaE = '[dbo].[TabPredna_EXT]'; + tblCisKoop = '[dbo].[TabCKoop]'; + + tblSdrPrikazy = '[dbo].[TabSdruzVyrPrikazy]'; + tblSdrPrikazyE = '[dbo].[TabSdruzVyrPrikazy_EXT]'; + tblSdrPrikazyR = '[dbo].[TabSdruzVyrPrikazyR]'; + tblSdrOperace = '[dbo].[TabSdruzVyrOperace]'; + tblSdrOperaceR = '[dbo].[TabSdruzVyrOperaceR]'; + tblKodySdruz = '[dbo].[TabCisKoduSdruzeni]'; + + tblRozpracOper = '[dbo].[TabEvidRozpracOper]'; + tblRozpracOperE = '[dbo].[TabEvidRozpracOper_EXT]'; + tblRozpracOperR = '[dbo].[TabEvidRozpracOperR]'; + tblRozpracOperRE = '[dbo].[TabEvidRozpracOperR_EXT]'; + tblRozpracOperPr = '[dbo].[TabEvidRozpracOperProstoje]'; + tblRozpracOperPrE = '[dbo].[TabEvidRozpracOperProstoje_EXT]'; + tblRozpracOperZm = '[dbo].[TabEvidRozpracOperRZmetky]'; + tblRozpracOperZmE = '[dbo].[TabEvidRozpracOperRZmetky_EXT]'; + + tblQMSCis = '[dbo].[TabQMSCis]'; + + tblKPParams = '[dbo].[TabKPParametry]'; + tblKPCisParamsKontr = '[dbo].[TabKPCisParametryKontrol]'; + + tblPrPostupKPs = '[dbo].[TabPostupKontrPostupy]'; + tblKPLHlav = '[dbo].[TabKPLHlav]'; // hlavicky kontrolniho planu + tblKPLHlavE = '[dbo].[TabKPLHlav_EXT]'; + tblKPLParams = '[dbo].[TabKPLParametry]'; // kontrolovane parametry planu + + tblAdvKPlan = '[dbo].[TabAdvKapacPlan]'; + tblAdvKPlanDavky = '[dbo].[TabAdvKPDavky]'; + tblAdvKPlanDavky_E = '[dbo].[TabAdvKPDavky_EXT]'; + tblAdvKPlanProfese = '[dbo].[TabAdvKPProfese]'; + tblAdvKPlanUseky = '[dbo].[TabAdvKPUseky]'; + tblAdvKPlanVypocty = '[dbo].[TabAdvKPVypocty]'; + tblKapacPlanPol = '[dbo].[TabKapacPlanPol]'; + + tblESSMsgs = '[dbo].[TabESServiceMessages]'; + + tblDefUzivTab = '[dbo].[TabDefTabUzivTabulka]'; + tblDefUzivTabAtr = '[dbo].[TabDefTabUzivAtributy]'; + +type + TRoundToEXRangeExtended = -20..20; + + TEchoReply = packed record + Addr: In_Addr; + Status: DWORD; + RoundTripTime: DWORD; + end; + PEchoReply = ^TEchoReply; + + THeliosParams = packed record + podbarveni: boolean; + colBg: integer; + delkaRC: byte; + FontName: AnsiString; + FontSize: Byte; + end; + + THeliosImages = class (TCustomImageList) + protected + FImageList32: TImageList; + public + constructor Create; + destructor Destroy; + property ImageList32: TImageList read FImageList32; + end; + + TIntEdit = class(TEdit) + protected + procedure KeyPress(var Key: Char); override; + end; + + TFloatEdit = class(TEdit) + protected + procedure KeyPress(var Key: Char); override; + end; + + ExceptionHelper = class helper for Exception + public + function Describe: string; + class procedure RaiseNotImplementedException(const aClass: TClass; const aMethodName: string); + class function GetStackTrace: string; + end; + EStackTraceException = class(Exception); // EProgrammerNotFound to make it really clear this is only to be used in very limited places ?? + +{ + TDuhaStringHelper = class helper for string + public + function StripChars(const InValidChars: SysUtils.TSysCharSet): string; + function RemoveAlphas: string; + function RemoveWords(const Words: TArray): string; + function RemoveNumbers: string; + end; +} + + TVariantHelper = record helper for Variant + function ToString: string; + function ToInteger: integer; + end; + +{ + TIntegerHelper = record helper for Integer + function Between (aInt, bInt: integer; incl: boolean=true): boolean; + end; +} + + TMaskedTextHelper = record helper for TMaskedText + function Contains (const Value: string): boolean; + function QuotedString: string; overload; + function Replace (OldChar: Char; NewChar: Char): string; overload; + function Replace (OldChar: Char; NewChar: Char; ReplaceFlags: TReplaceFlags): string; overload; + function Replace (const OldValue: string; const NewValue: string): string; overload; + function Replace (const OldValue: string; const NewValue: string; ReplaceFlags: TReplaceFlags): string; overload; + function LeftStr (charCount: Integer): string; + function RightStr (charCount: Integer): string; + function ToInteger (notValidValue: integer=-999999999): integer; overload; + function Trim: string; overload; + function StartsWith (const Value: string): boolean; overload; + function EndsWith (const Value: string): boolean; overload; + function Length: integer; overload; + function ToUpper: string; overload; + function ToLower: string; overload; + end; + + + TWideStringHelper = record helper for WideString + function QuotedString: string; overload; + end; + + + TCaptionHelper = record helper for TCaption + function QuotedString: string; overload; + function ToUpper: string; overload; + function ToLower: string; overload; + function ToInteger: integer; overload; + function ToExtended: Extended; overload; + function Trim: string; overload; + function Replace (sFind, sReplace: string): string; overload; + function LeftStr (charCount: Integer): string; overload; + function RightStr (charCount: Integer): string; overload; + function StartsWith (sStartsWith: string): boolean; + function EndsWith (sEndsWith: string): boolean; + function Contains (subString: string; caseSensitiv: boolean=false): boolean; + end; + + + TArrayUtils = class + public + class function Contains(const x: T; const anArray: array of T) : boolean; + end; + + + TwaitProgressThread = class; + TwaitFormThread = class(TForm) + private + FProgressBar: TProgressBar; + FLabel: TLabel; + procedure WMUpdateProgress (var Msg: TMessage); message WM_UPDATE_PROGRESS; + public + constructor CreateProgress (AOwner: TComponent=nil; napis: string=''; progBarMaxSize: integer=0; barColor: TColor=clRed); + end; + + TwaitProgressThread = class(TThread) + private + FTimer: THandle; + FFormParent: TForm; + FLock: TCriticalSection; + FForm: TwaitFormThread; + FProgBar: TProgressBar; + FMax: integer; + FTitulek: string; + FColor: TColor; + FProgBarMax: integer; + FProgBarColor: TColor; + protected + procedure Execute; + public + constructor Create (napis: string=''; AMax: integer=1; AColor: TColor=clRed; f: TForm=nil); + destructor Destroy; + procedure UpdateProgress (AValue: integer); + end; + + + + function GetAppVersionStr: string; + + function StringToCaseSelect(Selector : string; CaseList: TArray): Integer; + function VlozRadekPohybuZbozi(const Helios: IHelios; idDZ, idSS: integer; sz, regCis: string; mnoz, jc: Extended): integer; + + + /// + /// Funkce pro zaokrouhlední na daný počet desetiných míst + /// + /// + /// Hodnota pro zaokrouhlední + /// + /// + /// Počet desetiných míst + /// + /// + /// + /// RoundToEx(125.251,2) -> 125.25 + /// + /// + /// RoundToEx(125.251,-2) -> 126 + /// + /// + function RoundToEX(const AValue: Extended; const ADigit: TRoundToEXRangeExtended): Extended; + function IfThenInt(AValue: Boolean; const ATrue: integer; AFalse: integer = -1): integer; + function IfThenExt(AValue: Boolean; const ATrue: extended; AFalse: extended = -1): extended; + function IfThenBool(AValue: Boolean; const ATrue: Boolean; AFalse: Boolean = false): Boolean; + + /// + /// Funkce pro reseed tabulky s Identity indexem (DBCC CHECKIDENT) + /// + /// + /// IHelios + /// + /// + /// Název tabulky + /// + procedure ReseedTable (const Helios: IHelios; tblName:string); + procedure NactiParametryHeliosu (const Helios: IHelios; var pars: THeliosParams); + function GetUserColDef (const Helios: IHelios; tbl, col: string): string; + + function HeliosExistsTest (const Helios: IHelios; tbl, podm: string): boolean; + function HeliosExistsTestSQL (const Helios: IHelios; lSQL: string): boolean; + function HeliosZalozExtSloupec (const Helios: IHelios; tbl, sloupec, typ, velikost: string): boolean; + function HeliosZapisExtInfo (const Helios: IHelios; tbl, hodnota: string; idTab: integer): boolean; + function HeliosObjectExists (const Helios: IHelios; const tbl: string=''; const col: string=''): boolean; + function VratTableName (tbl: string): string; + function HeliosVratSazbuDPH (const Helios: IHelios; idKmen, druhPohybu: integer): extended; + + + procedure ScreenActiveControlChange (Sender: TObject); + function GetFileVersion2 (sFileName:string): string; + function GetProcessID (ProcessName:string): integer; + function GetPathFromPID (const PID: cardinal): string; + + function FormMnozstviCena (const Title: string; var mnoz,JC: Extended; const JCdleEvid,CenaEnabled: Boolean): Boolean; + function FormDatum (const Title, Desc: string; var datOut: TDatetime): Boolean; + function FormMemo (const Title, Desc: string; var memText: string): Boolean; + function FormCislo (const Title, Desc: string; var NumOut: Extended): Boolean; + function FormComboBox (const Title, Desc: string; const inStr: TStringList; var cbText: string): Boolean; + function FormComboBoxMemo (const Title, Desc, Desc2: string; const inStr: TStringList; var cbText, memoText: string; setFirst: boolean): Boolean; + function FormMemo2 (const Title: string; var mText: string; const readOnly: boolean; fontSize: integer): Boolean; + function FormInfo (const Title, Popis: string): boolean; + + + function sqlColIsNText (const Helios: IHelios; tabName, colName: string): boolean; + function getSQLTabOrColName (xName: string; returnColName: Boolean=true): string; + function getSQLInfoSchemaVal (const Helios: IHelios; tabName: string = ''; colName: string = ''; valName: string = ''): string; + function getSQLColumnType (const Helios: IHelios; tabName: string = ''; colName: string = ''): string; + function getSQLColumnDef (const Helios: IHelios; tabName: string = ''; colName: string = ''): string; + + function getHeliosBoolVal (const Helios: IHelios; const defVal: boolean; const sql: string): boolean; + + function getHeliosQueryIDs (const Helios: IHelios; const sql: string; emptyVal: string='-1'): string; + + /// + /// Spustí nad Heliosem SQL dotaz a vrátí String výsledek + /// + /// + /// interface IHelios + /// + /// + /// defaultne vracena hodnota, pokud SQL dotaz nic nenajde + /// + /// + /// text SQL příkazu + /// + /// + /// STRING hodnota + /// + function getHeliosStrVal(const Helios: IHelios; const defVal: string; sql: string): string; + + + /// + /// Spustí nad Heliosem SQL dotaz a vrátí String výsledek + /// + /// + /// interface IHelios + /// + /// + /// defaultne vracena hodnota, pokud SQL dotaz nic nenajde + /// + /// + /// text SQL příkazu + /// + /// + /// STRING hodnota + /// + function getHeliosDateTimeVal(const Helios: IHelios; const defVal: TDateTime; sql: string): TDateTime; + + + /// + /// Spustí nad Heliosem SQL dotaz a vrátí DATETIME výsledek + /// + /// + /// interface IHelios + /// + /// + /// defaultne vracena hodnota, pokud SQL dotaz nic nenajde + /// + /// + /// text SQL příkazu + /// + /// + /// FLOAT hodnota + /// + + function getHeliosFloatVal(const Helios: IHelios; const defVal: Extended; sql: string): Extended; + /// + /// Spustí nad Heliosem SQL dotaz a vrátí FLOAT/EXTENDED výsledek + /// + /// + /// interface IHelios + /// + /// + /// defaultne vracena hodnota, pokud SQL dotaz nic nenajde + /// + /// + /// text SQL příkazu + /// + /// + /// INT hodnota + /// + + + function getHeliosIntVal (const Helios: IHelios; const defVal: integer; sql: string): Integer; + + /// + /// Spustí nad Heliosem SQL dotaz a vrátí počet řádků jako INT výsledek + /// + /// + /// interface IHelios + /// + /// + /// text SQL příkazu + /// + /// + /// INT hodnota + /// + function getHeliosRowCount (const Helios: IHelios; sql: string): Integer; + + function sqlExistsTestGeneral (const Helios: IHelios; SQLText: string): boolean; + function sqlSanitize (inText: string): string; + + + /// + /// Z FireDAC tabulky třídy TFDMemTable uloží hodnoty zadaného sloupce do String-u + /// + /// + /// Tabulka typu TFDMemTable + /// + /// + /// Název sloupce + /// + /// + /// Hodnoty ze sloupce (oddělené čárkou) + /// + function IDckaTabulky(const tbl: TFDMemTable; pole: string): string; + + /// + /// IHelios + /// + /// + /// Název tabulky + /// + /// + /// Název sloupce jehož hodnotu hledáme + /// + /// + /// Druh pohybu zboží + /// + /// + /// ءda dokladů + /// + /// + /// Období dokladu + /// + /// + /// Další podmínka podle které hledat + /// + function NajdiPrvniVolny(const Helios: IHelios; Tab, Najdi, DruhPoh, RadaDokl, idObd, Podm: string): integer; + function ZapisDoKJ(const Helios: IHelios; Kat, Typ, Stav, Vystup, predmet, popis: string): integer; safecall; + + /// + /// Zjistí údaje o firmě (Název,IČŹ,DIČ© podle zadaného idOrg nebo CisloOrg + /// + /// + /// IHelios + /// + /// + /// Vrácený název organizace + /// + /// + /// Vrácené IČŹ + /// + /// + /// Vrácené DIČ + /// + function UdajeOFirme(const Helios: IHelios; idOrg,cisOrg: integer; var Nazev,ICO,DIC: string): boolean; + + /// + /// Kopíruje z clipboardu hodnoty do pole String + /// + /// + /// Příznak jestli se má smazat první importovaný řádek, kde bývá obvykle hlavička s názvy sloupců + /// + function Clipboard2StringArray (const SmazHead: boolean): TArray>; + function IsNumeric (const InputVal: string): boolean; + function IfNull (const Value, Default : OleVariant ) : OleVariant; + function ZmenNText (oVar: OleVariant): string; + function PosCount (substr: string; Strg: string): integer; + function PosCount2 (const SubStr, s: string): integer; + + /// + /// Najde N-tou pozici ASubStr v AStr + /// + /// + /// Prohledavany text + /// + /// + /// Hledany text + /// + /// + /// Hledana pozice + /// + function PosNthString (const AStr, ASubStr: string; n: integer): integer; + procedure DeleteGridRow (Grid: TStringGrid; ARow: integer); + + /// + /// Funkce pro převod pole typu TArray(int/extended) do proměnné typu string + /// + /// + /// Vstupní pole + /// + /// + /// Oddělovač hodnot + /// + /// + /// String + /// + function ArrayToString (const inArray: TArray; const delim: string; insZero: boolean=false): string; overload; + function ArrayToString (const inArray: TArray; const delim: string; insZero: boolean=false): string; overload; + function RemoveStringArrayItemsStartsWith (const inArray: TArray; const startText: string): TArray; + function FindInArray (const inArr: TArray; const i: integer): integer; overload; + function FindInArray (const inArr: TArray; const inStr: string): integer; overload; + + function getHeliosRowToStringDelim (const Helios: IHelios; const lSQL: string; const delim:char): string; + + function StrToArrayInt (aStr: string; const delim: string=','): TArray; + function StrToHex (S: AnsiString): AnsiString; + function MemStreamToHex (aStream: TMemoryStream): string; + function StringToMemoryStream (const AString: String): TMemoryStream; + function HexToMemoryStream (AString: string): TMemoryStream; + function HexToString (H: AnsiString): AnsiString; + + function xHexToDec (Hexadecimal: string): cardinal; + function xDecToBin (Decimal: cardinal): string; + function xHexToBin(Hexadecimal: string): string; + + function FileToHex (fName: string): string; + function TestFileExclusiveAccess (fName: string; ukazHlasku: Boolean=true): boolean; + + + function OtevriSoubor (const titulek,filtrTit,filtrMask: string; defDir: string; var nazev: string): Boolean; + function VyberAdresar (var Foldr: string; Title: string): Boolean; + + /// + /// V textové proměnné najde poslední pozici vybraného textu + /// + /// + /// Hledaný řetězec + /// + /// + /// Prohledávaný řetězec + /// + /// + /// Integer - index začátku hledaného řetězce + /// + function LastPos (const SubStr: String; const S: String): Integer; + + function GetSpecialFolderPath (Folder: Integer): string; + function VarToBool (V: Variant): Boolean; + + function RandomString (const aLength: byte; const startWith: string=''): string; + function SplitString (const aSeparator, aString: String; aMax: Integer = 0): TArray; + function StrIndex (const S: string; const List: TArray): integer; + function sStrIndex (const S: string; const List: TArray): integer; + function StrListRemoveEmpty (strList: TStringList): boolean; + function GetWidthText (const Text:String; Font: TFont) : Integer; + + + function waitStart2 (sMsg: string; maxPBar: integer=0; PBarColor: TColor=clRed; f: TForm=nil): TwaitProgressThread; + function waitEnd2 (thrd: TwaitProgressThread=nil): boolean; + + +/// +/// Vytvori infookno s progress barem v novem threadu +/// + function waitStart (TheParent: TComponent; sMsg: string; maxPBar: integer=1; PBarColor: TColor=clRed): TForm; +/// +/// Nastavi maximum progress baru +/// + procedure waitSetProgBarMax (maxPBar: integer); +/// +/// Nastavi hlasku infookna +/// + procedure waitSetMsg (sMsg: string); +/// +/// Nastavi pozici progress baru +/// + procedure waitSetProgBar (pozice: integer; wForm: TForm=nil); +/// +/// Ukonci info okno (thread) +/// + function waitEnd (wForm: TForm=nil): boolean; + + + + function CreateUniqueGUIDFileName(sPath, sPrefix, sExtension: string) : string; +/// +/// Vrati prvni index z comboboxu, u ktereho text zacina na dany string +/// +/// +/// Prohledavany ComboBox +/// +/// +/// Hledany string ze zacatku textu +/// +/// +/// Index (int), pokud nenajde vrati -1 +/// + function GetItemIndexStartingWith(const cbox: TComboBox; const S: string): integer; + + function StrQuotedEmptyNull (inStr: string): string; + function StrQuoted (inStr: string): string; + function StrToNQuotedList (inStr: string): string; + + function DateToSQL112Date (inStr: string): string; overload; + function DateToSQL112Date (inDate: TDatetime): string; overload; + + function SQLReseed (const Helios: IHelios; tabName: string): boolean; + function SQLColumnExists (const Helios: IHelios; tabName, colName: string): boolean; + function SQLObjectExists (const Helios: IHelios; objName: string): boolean; + + function SQLTryConvertNumNullDefVal (const convTyp: string; const inVal: string; const defVal: integer): string; + function SQLDatetimeConvert (const inDat: TDateTime; const noTime: boolean=false): string; + function SQLGetRowCount (const Helios: IHelios; lSQL: string): integer; + function SQLTestCreateTable (const Helios: IHelios; tbl, tblDef: string): boolean; + function RemoveTableNamePrefix (inStr: string): string; + function RemoveTableNameBrackets (inStr: string): string; + + + function StripChars (const Text: string; const InValidChars: SysUtils.TSysCharSet): string; + function RemoveWords (const Text: string; const Words: TArray): string; + function RemoveNumbers (const AString: string): string; + function RemoveAlphas (const AString: string): string; + function getHeliosQuery (const Helios:IHelios; const sqlQuery: string): TArray>; + + function ZapisLastSettings (const Helios: IHelios; const cislo: integer; const sekce: integer; const hodnota: string): boolean; + + function NajdiBID (const Helios: IHelios; bidName: string): integer; + + + function IsWow64: Boolean; + function IsAdmin (Host : string = '') : Boolean; + function IsPhysicalKeyboardConnected: Boolean; + function DetectRemoteSession: boolean; + function IsRemoteSession: Boolean; // zjisti zda jsem na vzdalene plose, tj. mam remote session + function GetClientComputerName (const typ:byte=0): string; + function IsDirectoryWriteable (const AName: string): Boolean; + + function IcmpCreateFile: THandle; stdcall; external 'iphlpapi.dll'; + function IcmpCloseHandle (icmpHandle: THandle): boolean; stdcall; external 'iphlpapi.dll'; + function IcmpSendEcho (icmpHandle: THandle; DestinationAddress: In_Addr; RequestData: Pointer; RequestSize: Smallint; RequestOptions: Pointer; + ReplyBuffer: Pointer; ReplySize: DWORD; Timeout: DWORD): DWORD; stdcall; external 'iphlpapi.dll'; + function PingHost (const HostName: AnsiString; timeoutMs: cardinal=500): boolean; + function NetGetURLProtocol (const URL: string): string; + function NetGetHostName (myURL: string): string; + function NetGetHostNameWithProtocol (myURL: string): string; + function NetGetHostPort (myURL: string): string; + + procedure OrizniBitmapu (const ASourceBitmap: TBitmap; out ACroppedBitmap: TBitmap; BackgroundColor: TColor = clWhite); + procedure NajdiContentBounds (const ABitmap: TBitmap; out Left, Top, Right, Bottom: Integer; BackgroundColor: TColor = clWhite); + +implementation +{$R *.res} +uses System.StrUtils, System.Variants, System.TypInfo, Vcl.Clipbrd, Vcl.Dialogs, + Winapi.PsAPI, Winapi.ShlObj, System.RegularExpressions, + arrayHelper, myUtils; + +var lastFocused: TWinControl; + oldCol: Integer; + doEnter, doExit: Boolean; + waitForm: TForm; + waitLabel: TLabel; + waitPBar: TProgressBar; + + + +{ IntegerHelper } +{ + function TIntegerHelper.Between (aInt, bInt: integer; incl: boolean=true): boolean; + begin + result:= false; + if (incl) then + begin + if (aInt<=self) and (bInt>=self) then + result:= true; + end + else + begin + if (aIntself) then + result:= true; + end; + end; +} + + +{ WideStringHelper } + function TWideStringHelper.QuotedString: string; + begin + Result:= string(Self).QuotedString; + end; + + + + +{ ExceptionHelper } + + function ExceptionHelper.Describe: string; + var lStackTrace: string; + begin + result := inherited ToString(); + if Self is EInOutError then + if Result = System.RTLConsts.SInvalidFileName then + Result := System.SysConst.SInvalidFileName; + if Assigned(StackInfo) then + lStackTrace := StackTrace + else + lStackTrace := 'empty'; + result := Format('Exception'#13#10'%s at $%p: %s'#13#10'with StackTrace'#13#10'%s', [ClassName, ExceptAddr, Result, lStackTrace]); + end; + + + + class function ExceptionHelper.GetStackTrace: string; + begin + try + Result := 'Get StackTrace via Exception.'; + raise EStackTraceException.Create(Result) at ReturnAddress; + except on E: EStackTraceException do + Result := E.StackTrace; + end; + end; + + + + class procedure ExceptionHelper.RaiseNotImplementedException(const aClass: TClass; const aMethodName: string); + begin + raise ENotImplemented.CreateFmt('Method %s.%s is not implemented.', [aClass.ClassName, aMethodName]); + end; + + + + +{ TVarinatHelper } + function TVariantHelper.ToString: string; + begin + result:= VarToStr(self); + end; + + function TVariantHelper.ToInteger: integer; + var v: Variant; + begin + result:= -999999999; + if VarIsNumeric(self) then + TryStrToInt(VarToStr(self), result); + end; + + + +{ TMaskedTextHelper } + + function TMaskedTextHelper.Contains (const Value: string): boolean; + var s: string; + begin + s:= Self; + result:= (s.Contains(Value)); + end; + + function TMaskedTextHelper.QuotedString: string; + var I: Integer; + s: string; + begin + s:= Self; + result:= s.Substring(0); + for I:= result.Length - 1 downto 0 do + if (result.Chars[I] = '''') then + result := result.Insert(I, ''''); + result:= '''' + result + ''''; + end; + + function TMaskedTextHelper.LeftStr (charCount: Integer): string; + begin + result:= ''; + if (System.Length(self)>0) then + result:= System.StrUtils.LeftStr (self, charCount); + end; + + function TMaskedTextHelper.RightStr (charCount: Integer): string; + begin + result:= ''; + if (System.Length(self)>0) then + result:= System.StrUtils.RightStr (Self, charCount); + end; + + function TMaskedTextHelper.Replace (OldChar, NewChar: Char): string; + begin + Result:= System.SysUtils.StringReplace (Self, OldChar, NewChar, [rfReplaceAll]); + end; + + function TMaskedTextHelper.Replace (OldChar: Char; NewChar: Char; ReplaceFlags: TReplaceFlags): string; + begin + Result:= System.SysUtils.StringReplace (Self, OldChar, NewChar, ReplaceFlags); + end; + + function TMaskedTextHelper.Replace (const OldValue, NewValue: string): string; + begin + Result:= System.SysUtils.StringReplace (Self, OldValue, NewValue, [rfReplaceAll]); + end; + + function TMaskedTextHelper.Replace (const OldValue: string; const NewValue: string; ReplaceFlags: TReplaceFlags): string; + begin + Result:= System.SysUtils.StringReplace (Self, OldValue, NewValue, ReplaceFlags); + end; + + function TMaskedTextHelper.StartsWith(const Value: string): Boolean; + begin + result:= (self.LeftStr(Value.Length).ToLower=Value.ToLower); + end; + + function TMaskedTextHelper.EndsWith(const Value: string): Boolean; + begin + result:= (self.RightStr(Value.Length).ToLower=Value.ToLower); + end; + + function TMaskedTextHelper.Length: integer; + var x: string; + begin + x:= self; + result:= x.Length; + end; + + function TMaskedTextHelper.ToInteger (notValidValue: integer=-999999999): integer; + var i: Integer; + begin + i:= notValidValue; + if not(TryStrToInt(self, i)) then + i:= notValidValue; + result:= i; + end; + + function TMaskedTextHelper.Trim: string; + var x: string; + begin + x:= self; + result:= x.Trim; + end; + + function TMaskedTextHelper.ToUpper: string; + begin + result:= UpperCase(self); + end; + + function TMaskedTextHelper.ToLower: string; + begin + result:= LowerCase(self); + end; + + + +{ TCaptionHelper } + function TCaptionHelper.QuotedString: string; + var I: Integer; + s: string; + begin + s:= Self; + result:= s.Substring(0); + for I:= result.Length - 1 downto 0 do + if (result.Chars[I] = '''') then + result := result.Insert(I, ''''); + result:= '''' + result + ''''; + end; + + function TCaptionHelper.ToUpper: string; + begin + result:= UpperCase(self); + end; + + function TCaptionHelper.ToLower: string; + begin + result:= LowerCase(self); + end; + + function TCaptionHelper.ToInteger: integer; + var i: Integer; + begin + i:= -999999999; + if not(TryStrToInt(self, i)) then + i:= -999999999; + result:= i; + end; + + function TCaptionHelper.ToExtended: Extended; + var e: Extended; + begin + e:= -999999999.0; + if not(TryStrToFloat(self, e)) then + e:= -999999999.0; + result:= e; + end; + + function TCaptionHelper.Trim: string; + var x: string; + begin + x:= self; + result:= x.Trim; + end; + + function TCaptionHelper.Replace (sFind: string; sReplace: string): string; + begin + result:= StringReplace(self, sFind, sReplace, [rfReplaceAll, rfIgnoreCase]); + end; + + function TCaptionHelper.LeftStr (charCount: Integer): string; + begin + result:= ''; + if (Length(self)>0) then + result:= System.StrUtils.LeftStr(Self, charCount); + end; + + function TCaptionHelper.RightStr (charCount: Integer): string; + begin + result:= ''; + if (Length(self)>0) then + result:= System.StrUtils.RightStr(Self, charCount); + end; + + function TCaptionHelper.EndsWith (sEndsWith: string): Boolean; + begin + result:= (RightStr(Length(sEndsWith)).ToLower=sEndsWith.ToLower); + end; + + function TCaptionHelper.StartsWith (sStartsWith: string): Boolean; + begin + result:= (LeftStr(Length(sStartsWith)).ToLower=sStartsWith.ToLower); + end; + + function TCaptionHelper.Contains (subString: string; caseSensitiv: boolean=false): Boolean; + var x: string; + begin + x:= self; + if not(caseSensitiv) then + result:= System.StrUtils.ContainsStr (x, subString) + else + result:= x.Contains (subString); + end; + + + +{ TArrayUtils } + class function TArrayUtils.Contains(const x: T; const anArray: array of T): boolean; + var y : T; + lComparer: IEqualityComparer; + begin + lComparer := TEqualityComparer.Default; + for y in anArray do + begin + if lComparer.Equals(x, y) then + Exit(True); + end; + Exit(False); + end; + + + + + +{ StringHelper } +{ class function StringHelper.StripChars(const InValidChars: SysUtils.TSysCharSet): string; + var i, j, zbsAdj : Integer; + begin + SetLength(Result,Length(Text)); // Preallocate result maximum length + j:= 0; // Resulting string length counter + zbsAdj:= 1-Low(String); // Handles zero based string offset + for i:= Low(Text) to High(Text) do + begin + if not CharInSet(Text[i],InValidChars) then + begin + Inc(j); + Result[j-zbsAdj] := Text[i]; + end; + end; + SetLength(Result, j); // Set result actual length + end; + + + + class function StringHelper.RemoveWords(const Words: TArray'') then + begin + with Helios.OpenSQL('SELECT 100000+Cislo FROM ' + tblObecPrehled + ' WHERE NazevSys=N' + QuotedStr(bidName)) do + if (RecordCount=1) then + result:= StrToInt(VarToStr(FieldValues(0))); + end; + end; + + + + function SQLReseed (const Helios: IHelios; tabName: string): boolean; + var lSQL, schemaName, identCol: string; + c: byte; + begin + result:= false; + if (tabName<>'') then + begin + tabName:= TRegEx.Replace(tabName, '[\[\]]', ''); + schemaName:= 'dbo'; + c:= Length(TRegEx.Replace(tabName,'[^.]','')); + if (c=1) then + begin + schemaName:= LeftStr(tabName, tabName.IndexOf('.')); + tabName:= tabName.Substring(tabName.IndexOf('.')+1); + end; + + if (c=0) or (c=1) then + begin + lSQL:= 'SELECT c.[name] FROM sys.objects o INNER JOIN sys.columns c ON (o.object_id=c.object_id) INNER JOIN sys.schemas s ON (s.schema_id=o.schema_id)'; + lSQL:= lSQL + ' WHERE c.is_identity=1 AND s.name=' + schemaName.QuotedString + ' AND o.name=' + tabName.QuotedString; + with Helios.OpenSQL(lSQL) do + if (RecordCount=1) then + begin + identCol:= VarToStr(FieldByNameValues('name')); + lSQL:= 'IF NOT EXISTS(SELECT * FROM ' + tabName + ') TRUNCATE TABLE ' + schemaName + '.' + tabname; + lSQL:= lSQL + ' ELSE' + CRLF + 'BEGIN' + CRLF + ' DECLARE @i INT' + CRLF + ' SELECT @i=MAX(' + identCol + ') FROM ' + schemaName + '.' + tabname; + lSQL:= lSQL + CRLF + ' DBCC CHECKIDENT(' + tabName + ', RESEED, @i)' + CRLF + 'END'; + Helios.ExecSQL(lSQL); + result:= true; + end; + end; + end; + end; + + + + + + function SQLColumnExists (const Helios: IHelios; tabName, colName: string): boolean; + var lSQL: string; + begin + result:= false; + tabName:= tabName.Replace('[','').Replace(']',''); + if not (tabName.StartsWith('#')) then + begin + if not(tabName.StartsWith('dbo.')) then + tabName:= 'dbo.' + tabName; + end + else + if not(tabName.StartsWith('tempdb..')) then + tabName:= 'tempdb..' + tabName; + if (tabName<>'') and (colName<>'') then + begin + try + lSQL:= 'IF COL_LENGTH(N' + tabName.QuotedString + ', N' + colName.QuotedString + ') IS NOT NULL SELECT 1 ELSE SELECT 0'; + with Helios.OpenSQL(lSQL) do + if (RecordCount=1) then + if (VarToStr(Fields(0).Value).ToInteger=1) then + result:= true; + except + end; + end; + end; + + + + + function SQLObjectExists (const Helios: IHelios; objName: string): boolean; + var lSQL: string; + begin + result:= false; + if (LeftStr(objName,1)='#') then + objName:= 'tempdb..' + objName; + + if (objName.Replace('[','').Replace(']','')<>'') then + begin + try + lSQL:= 'IF OBJECT_ID(N' + objName.Replace('[','').Replace(']','').QuotedString + ') IS NOT NULL SELECT 1 ELSE SELECT 0'; + with Helios.OpenSQL(lSQL) do + if (RecordCount=1) then + if (VarToStr(Fields(0).Value).ToInteger=1) then + result:= true; + except + end; + end; + end; + + + + + + function SQLTryConvertNumNullDefVal (const convTyp: string; const inVal: string; const defVal: integer): string; + begin + result:= ''; + if (convTyp.ToLower='int') or (convTyp.ToLower='numeric') then + result:= 'ISNULL(TRY_CONVERT(' + convTyp + ', ' + StringReplace(inVal, ',', '.', [rfReplaceAll]) + '), ' + defVal.ToString+')'; + end; + + + + function SQLDatetimeConvert (const inDat: TDateTime; const noTime: boolean=false): string; + begin + if (inDat=0) then + result:= 'NULL' + else + begin + if (noTime) then + result:= 'CONVERT(datetime, CONVERT(int, CONVERT(float, CONVERT(datetime, N' + FormatDateTime('dd.mm.yyyy', inDat).QuotedString + ', 104))))' + else + result:= 'CONVERT(datetime,N' + FormatDateTime('dd.mm.yyyy hh:nn:ss', inDat).QuotedString + ', 104)'; + end; + end; + + + + function SQLGetRowCount (const Helios: IHelios; lSQL: string): integer; + begin + result:= 0; + try + with Helios.OpenSQL(lSQL) do + result:= RecordCount; + finally + end; + end; + + + + + function SQLTestCreateTable (const Helios: IHelios; tbl, tblDef: string): boolean; + var lSQL: string; + begin + lSQL:= ''; + result:= false; + if (tbl<>'') then + begin + if not(tbl.Contains('dbo.')) and not(tbl.Contains('dbo].')) and not(tbl.Contains('.')) then + tbl:= 'dbo.' + tbl; + + if (tblDef<>'') then + lSQL:= 'IF OBJECT_ID(N' + tbl.QuotedString + ') IS NULL CREATE TABLE ' + tbl + ' (' + tblDef + ')' + CRLF; + + lSQL:= lSQL + 'SELECT CONVERT(tinyint, CASE WHEN OBJECT_ID(N' + tbl.QuotedString + ') IS NULL THEN 0 ELSE 1 END)'; + try + with Helios.OpenSQL(lSQL) do + if (VarToStr(FieldValues(0))='1') then + result:= true; + except + end; + end; + end; + + + + + function RemoveTableNamePrefix (inStr: string): string; + begin + result:= inStr.Replace('[', '').Replace(']', '').Replace('dbo.', ''); + end; + + + function RemoveTableNameBrackets(inStr: string): string; + begin + result:= inStr.Replace('[', '').Replace(']', ''); + end; + + + + + + function sqlColIsNText (const Helios: IHelios; tabName, colName: string): boolean; + var lSQL: string; + begin + result:= false; + if (tabName<>'') and (colName<>'') then + begin + lSQL:= 'SELECT 1 FROM sys.columns COL INNER JOIN sys.tables TAB ON (COL.object_id = TAB.object_id) INNER JOIN sys.types TYP'; + lSQL:= lSQL + ' ON (TYP.user_type_id = COL.user_type_id) INNER JOIN sys.schemas SCHM ON (TAB.schema_id=SCHM.schema_id)'; + lSQL:= lSQL + ' WHERE SCHM.[name]=N''dbo'' AND TYP.system_type_id=99 AND TAB.[name]=N' + tabName.QuotedString; + lSQL:= lSQL + ' AND COL.[name]=N' + colName.QuotedString; + with Helios.OpenSQL (lSQL) do + if (RecordCount=1) then + result:= true; + end; + end; + + + + + function getHeliosQuery (const Helios:IHelios; const sqlQuery: string): TArray>; + var retArr: TArray>; + iR, iC: integer; + begin + SetLength(retArr,0,0); + if (sqlQuery<>'') then + begin + with Helios.OpenSQL(sqlQuery) do + if (RecordCount>0) then + begin + SetLength(retArr, RecordCount, FieldCount); + First; + iR:= 0; + while not(EOF) do + begin + for iC:=0 to FieldCount-1 do + retArr[iR, iC]:= VarToStr(FieldValues(iC)); + Inc(iR); + Next; + end; + end; + end; + result:= retArr; + end; + + + + + function StripChars(const Text: string; const InValidChars: SysUtils.TSysCharSet): string; + var i, j, zbsAdj : Integer; + begin + SetLength(Result,Length(Text)); // Preallocate result maximum length + j:= 0; // Resulting string length counter + zbsAdj:= 1-Low(String); // Handles zero based string offset + for i:= Low(Text) to High(Text) do + begin + if not CharInSet(Text[i],InValidChars) then + begin + Inc(j); + Result[j-zbsAdj] := Text[i]; + end; + end; + SetLength(Result,j); // Set result actual length + end; + + + + function RemoveWords(const Text: string; const Words: TArray): string; + var iFirst, iLast: integer; + begin + Result:= Text; + if MatchText(Text, Words) then + begin + iFirst:= Low(Words); + iLast:= High(Words); + while (iFirst<=iLast) do + begin + Result:= StringReplace(Result, Words[iFirst], '', [rfReplaceAll, rfIgnoreCase]); + Inc(iFirst); + end; + end; + end; + + + + + function RemoveNumbers(const AString: string): string; + var i, j: integer; + begin + result:= AString; +{ SetLength(result, AString.Length); + j:= 0; + for i:= 1 to AString.Length do + if not AString[i].IsDigit then + begin + Inc(j); + result[j]:= AString[i]; + end; + SetLength(result, j); +} + end; + + + + + function RemoveAlphas(const AString: string): string; + var i, j: integer; + begin + result:= AString; +{ + SetLength(result, AString.Length); + j:= 0; + for i:= 1 to AString.Length do + if not AString[i].IsLetter then + begin + Inc(j); + result[j]:= AString[i]; + end; + SetLength(result, j); +} + end; + + + + + function StrQuoted(inStr: string): string; + begin + result:= ''; + inStr:= Trim(inStr); + if (inStr<>'') then + result:= inStr; + end; + + + + function StrToNQuotedList (inStr: string): string; + var x: string; + begin + inStr:= inStr.Trim; + x:= inStr; + if (x.Contains(',')) then + begin + while (x.Contains(',')) do + begin + result:= 'N' + LeftStr(x, x.IndexOf(',')).QuotedString + ','; + x:= MidStr(x, x.IndexOf(','), Length(x)); + end; + end + else + x:= 'N' + x.QuotedString; + result:= x; + end; + + + + + function DateToSQL112Date (inStr: string): string; + begin + result:= ''; + if (inStr.Length=19) then // 01.01.2024 12:00:00 + begin + if (MidStr(inStr, 3, 1)='.') and (MidStr(inStr, 6, 1)='.') and (MidStr(inStr, 11, 1)=' ') then + result:= MidStr(inStr, 7, 4) + MidStr(inStr, 4, 2) + LeftStr(inStr, 2); + end + else + result:= ''; + end; + + + + function DateToSQL112Date (inDate: TDatetime): string; + begin + result:= FormatDateTime ('yyyymmdd', inDate); + end; + + + + function StrQuotedEmptyNull(inStr: string): string; + begin + result:= 'N'; + inStr:= Trim(inStr); + if (inStr<>'') then + result:= result + QuotedStr(inStr) + else + result:= result + 'ULL'; + end; + + + + + function GetUserColDef(const Helios: IHelios; tbl, col:string): string; + begin + result:= ''; + tbl:= StringReplace(tbl, '[', '', [rfReplaceAll]); + tbl:= StringReplace(tbl, ']', '', [rfReplaceAll]); +// tbl:= StringReplace(tbl, 'dbo.', '', [rfReplaceAll]); + if (LowerCase(LeftStr(tbl,4))<>'dbo.') then + tbl:= 'dbo.' + tbl; + if (LeftStr(tbl,1)<>'#') and (LowerCase(LeftStr(tbl,6))<>'tempdb') then + with Helios.OpenSQL('SELECT CONVERT(int, CASE WHEN OBJECT_ID(N' + tbl.QuotedString + ') IS NOT NULL THEN 1 ELSE 0 END)') do + if (VarToStr(FieldValues(0))='1') then + result:= getHeliosStrVal(Helios, '', 'SELECT DefiniceAtr FROM ' + tblUzivAtr + ' WHERE NazevTabulkySys=N' + StringReplace(tbl, 'dbo.', '', [rfReplaceAll]).QuotedString + ' AND NazevAtrSys=N' + col.QuotedString); + end; + + + + + function ZapisLastSettings (const Helios: IHelios; const cislo: integer; const sekce: integer; const hodnota: string): boolean; + var lSQL, podm: string; + begin + result:= false; + if (cislo>0) and (sekce>=0) then + begin + podm:= ' AND Sekce=' + sekce.ToString + ' AND Autor=SUSER_SNAME()'; + lSQL:= 'IF NOT EXISTS(SELECT * FROM ' + tblLastSet + ' WHERE Cislo=' + cislo.ToString + podm + ')' + CRLF + ' INSERT ' + tblLastSet + ' (Cislo, Sekce, Autor)'; + lSQL:= lSQL + ' SELECT ' + cislo.ToString + ', ' + sekce.ToString + ', SUSER_SNAME()' + CRLF; + lSQL:= lSQL + 'UPDATE ' + tblLastSet + ' SET Hodnota=N' + hodnota.QuotedString + ' WHERE Cislo=' + cislo.ToString + podm + CRLF; + try + Helios.ExecSQL(lSQL); + result:= true; + except + end; + end; + end; + + + + + function VratTableName (tbl: string): string; + begin +{ + tbl:= StringReplace(tbl, '[dbo].[', '', [rfReplaceAll]); + if (RightStr(tbl,1)=']') then + tbl:= LeftStr(tbl, Length(tbl)-1); + tbl:= StringReplace(tbl, 'dbo.', '', [rfReplaceAll]); + result:= tbl; +} + result:= tbl.Replace('[', '').Replace(']', '').Replace('dbo.', ''); + end; + + + + + function HeliosZalozExtSloupec (const Helios: IHelios; tbl, sloupec, typ, velikost: string): boolean; + var lSQL: string; + begin + result:= false; + + tbl:= tbl.Replace('[', '').Replace(']', '').Trim; + sloupec:= sloupec.Trim; + typ:= typ.Trim; + velikost:= velikost.Trim; + if (tbl<>'') and not(tbl.StartsWith('dbo.', true)) then + tbl:= 'dbo.' + tbl; + if (sloupec<>'') and not(sloupec.StartsWith('_', true)) then + sloupec:= '_' + sloupec; + if (tbl='') or (sloupec='') or (typ='') then + Exit; + + if (helUtils.HeliosObjectExists (Helios, tbl, '')) then + if not(helUtils.HeliosObjectExists (Helios, tbl, sloupec)) then + begin + lSQL:= 'SELECT 1 FROM dbo.TabUzivAtr WHERE Externi=1 AND NazevTabulkySys=N' + tbl.Replace('dbo.', '').QuotedString + ' AND NazevAtrSys=N' + sloupec.QuotedString; + if not(helUtils.sqlExistsTestGeneral(Helios, lSQL)) then + begin + lSQL:= 'EXEC dbo.hp_ExterniTabulka N' + tbl.Replace('dbo.', '').QuotedString + ', N' + sloupec.QuotedString + ', N' + + (typ + IfThen(velikost<>'', ' (' + velikost + ')', '')).QuotedString; + Helios.ExecSQL (lSQL); + + lSQL:= 'INSERT ' + tblUzivAtr + ' (Externi, NazevTabulkySys, NazevAtrSys, NazevAtrVer, TypAtr, SirkaSloupceAtr) SELECT 1, N' + tbl.Replace('dbo.', '').QuotedString; + lSQL:= lSQL + ', N' + sloupec.QuotedString + ', N' + sloupec.QuotedString + ', N' + typ.QuotedString + ', 0' + CRLF; +// lSQL:= lSQL + 'ALTER TABLE ' + tbl.Replace('dbo.', '') + ' ADD ' + sloupec + ' ' + typ + IfThen(velikost<>'', ' (' + velikost + ')', ''); + try + Helios.ExecSQL (lSQL); + result:= true; + except + end; + end; + end; + end; + + + + + function HeliosZapisExtInfo (const Helios: IHelios; tbl, hodnota: string; idTab: integer): boolean; + begin + result:= false; + tbl:= Trim(tbl); + tbl:= StringReplace(tbl, '[', '', [rfReplaceAll]); + tbl:= StringReplace(tbl, ']', '', [rfReplaceAll]); + hodnota:= Trim(hodnota); + if (hodnota<>'') and (tbl<>'') and (LeftStr(tbl,1)<>'#') then + try + if not(HeliosExistsTest (Helios, tbl, 'ID=' + idTab.ToString)) then + begin + Helios.ExecSQL('INSERT ' + tbl + ' (ID) VALUES (' + idTab.ToString + ')'); + Helios.ExecSQL('UPDATE ' + tbl + ' SET ' + hodnota + ' WHERE ID=' + idTab.ToString); + result:= true; + end; + except + end; + end; + + + + + function HeliosExistsTest (const Helios: IHelios; tbl, podm: string): boolean; + begin + result:= false; + tbl:= Trim(tbl); + tbl:= StringReplace(tbl, '[', '', [rfReplaceAll]); + tbl:= StringReplace(tbl, ']', '', [rfReplaceAll]); + podm:= Trim(podm); + try + if (LeftStr(tbl,1)='#') then + tbl:= 'tempdb..' + tbl; + if (LowerCase(LeftStr(tbl,6))<>'tempdb') and (LowerCase(LeftStr(tbl,4))<>'dbo.') then + tbl:= 'dbo.' + tbl; + with Helios.OpenSQL('SELECT CONVERT(int, CASE WHEN OBJECT_ID(N' + tbl.QuotedString + ') IS NOT NULL THEN 1 ELSE 0 END)') do + if (VarToStr(FieldValues(0))='1') then + begin + with Helios.OpenSQL('SELECT * FROM ' + tbl + IfThen(podm<>'', ' WHERE ' + podm, '')) do + if (RecordCount>0) then + result:= true; + end; + except + end; + end; + + + + + function HeliosExistsTestSQL(const Helios: IHelios; lSQL: string): boolean; + begin + result:= false; + try + with Helios.OpenSQL(lSQL) do + if (RecordCount>=1) then + result:= true; + except + end; + end; + + + + + function HeliosObjectExists (const Helios: IHelios; const tbl: string = ''; const col: string = ''): boolean; + var t: string; + begin + result:= false; + t:= tbl; + + if (LeftStr(t,1)='#') then + t:= 'tempdb..' + t + else + begin + if not(t.Contains('dbo.')) and not(t.Contains('[dbo].')) then + t:= 'dbo.' + t; + end; + t:= t.Replace('[', '').Replace(']', ''); + + if (col<>'') then + begin + if (t<>'dbo.') and (t<>'tempdb..') then + with Helios.OpenSQL('SELECT CASE WHEN COL_LENGTH(N' + t.QuotedString + ', N' + col.QuotedString + ') IS NOT NULL THEN 1 ELSE 0 END') do + if (VarToStr(FieldValues(0))='1') then + result:= true; + end + else + if (t<>'dbo.') and (t<>'tempdb..') then + with Helios.OpenSQL('SELECT CASE WHEN OBJECT_ID(N' + t.QuotedString + ') IS NOT NULL THEN 1 ELSE 0 END') do + if (VarToStr(FieldValues(0))='1') then + result:= true; + + end; + + + + + function FindInArray(const inArr: TArray; const i: integer): integer; + var q: integer; + begin + result:= -1; + for q:=0 to Length(inArr)-1 do + if inArr[q]=i then + begin + result:= q; + Break; + end; + end; + + + + + function FindInArray(const inArr: TArray; const inStr: string): integer; + var q: integer; + begin + result:= -1; + for q:=0 to Length(inArr)-1 do + if inArr[q]=inStr then + begin + result:= q; + Break; + end; + end; + + + + + function GetItemIndexStartingWith(const cbox: TComboBox; const S: string): integer; + var i: integer; + cnt: integer; + begin + result:= -1; + i:= 0; + cnt:= Length(S); + while (i<=cbox.Items.Count-1) and (result=-1) do + begin + if (LowerCase(LeftStr(cbox.Items.Strings[i],cnt))=LowerCase(S)) then + result:= i; + end; + end; + + + + + + function StringToCaseSelect(Selector : string; CaseList: TArray): Integer; + var cnt: integer; + begin + Result:= -1; + for cnt:=0 to Length(CaseList)-1 do + begin + if CompareText(Selector, CaseList[cnt]) = 0 then + begin + Result:= cnt; + Break; + end; + end; + end; + + + + + function VlozRadekPohybuZbozi(const Helios: IHelios; idDZ, idSS: integer; sz, regCis: string; mnoz, jc: Extended): integer; + var lSQL: string; + begin + result:= 0; + lSQL:= 'IF OBJECT_ID(N' + QuotedStr('tempdb..#TabExtKom') + ') IS NULL CREATE TABLE #TabExtKom (Poznamka NVARCHAR(255))' + CRLF; + lSQL:= lSQL + 'IF OBJECT_ID(N' + QuotedStr('tempdb..#TabTempUziv') + ') IS NULL CREATE TABLE #TabTempUziv (Tabulka'; + lSQL:= lSQL + ' NVARCHAR(255) NOT NULL, SCOPE_IDENTITY INT NULL, Datum DATETIME NULL)' + CRLF; + lSQL:= lSQL + 'DECLARE @idPZ INT, @idSS INT, @cOrg INT, @vstC TINYINT, @dpz TINYINT, @jednM INT, @kurzDZ NUMERIC(19,6), @menaDZ NVARCHAR(3), @skl NVARCHAR(30)' + CRLF; + lSQL:= lSQL + 'SELECT @cOrg=CisloOrg, @menaDZ=Mena, @kurzDZ=Kurz, @dpz=DruhPohybuZbo, @skl=IDSklad, @jednM=JednotkaMeny, @vstC=VstupniCena FROM ' + tblDZ + ' WHERE ID=' + idDZ.ToString + CRLF; + if (idSS=0) and (sz<>'') and (regCis<>'') then + begin + lSQL:= lSQL + 'SET @idKZ=(SELECT ID FROM ' + tblKZ + ' WHERE SkupZbo=N' + sz.QuotedString + ' AND RegCis=N' + regCis.QuotedString + ')' + CRLF; + lSQL:= lSQL + 'SET @idSS=(SELECT ID FROM ' + tblSS + ' WHERE IDKmenZbozi=@idKZ AND IDSklad=@skl)' + CRLF; + end + else + lSQL:= lSQL + 'SET @idSS=' + idSS.ToString + CRLF; + lSQL:= 'BEGIN TRY' + CRLF + ' EXEC dbo.hp_InsertPolozkyOZ @ident=@idPZ OUT, @IDDoklad=' + idDZ.ToString + ', @DruhPohybu=@dpz, @CisloOrg=@cOrg, @IDZboSklad=@idSS, @JCbezDaniKC='; + lSQL:= lSQL + StringReplace(FloatToStr(jc), ',', '.', [rfReplaceAll]) + ', @Mena=@menaDZ, @Kurz=@kurzDZ, @JednotkaMeny=@jednM, @KurzEuro=0, @SazbaSD=0, @SazbaDPH=0, @ZakazanoDPH=0'; + lSQL:= lSQL + ', @VstupniCena=@vstC, @PovolitDuplicitu=1, @PovolitBlokovane=1' + ', @Mnozstvi=' + StringReplace(FloatToStr(mnoz), ',', '.', [rfReplaceAll]) + CRLF; + lSQL:= lSQL + 'END TRY' + CRLF + 'BEGIN CATCH' + CRLF + ' SET @idPZ=0' + CRLF + 'END CATCH' + CRLF + ' SELECT @idPZ'; + with Helios.OpenSQL(lSQL) do + result:= StrToInt(VarToStr(FieldValues(0))); + end; + + + + + + function HeliosVratSazbuDPH(const Helios: IHelios; idKmen, druhPohybu: integer): extended; + var lSQL: string; + begin + result:= -1; + lSQL:= 'DECLARE @s NUMERIC(5,2)=-1, @druhS TINYINT, @pdp BIT' + CRLF + 'EXEC dbo.hp_GetSazbuDPH @SazbaDPH=@s OUT, @DruhSazbyDPH=@druhS OUT, @DPHPrenesPov=@pdp OUT'; + lSQL:= lSQL + ', @IDKmenZbozi=' + idKmen.ToString + ', @DruhPohybu=' + druhPohybu.ToString + CRLF; + lSQL:= lSQL + 'SELECT @s'; + try + with Helios.OpenSQL(lSQL) do + lSQL:= VarToStr(FieldValues(0)); + if not(TryStrToFloat(lSQL, result)) then + result:= -1; + except + end; + end; + + + + + constructor TwaitProgressThread.Create (napis: string=''; AMax: Integer = 1; AColor: TColor = 255; f: TForm=nil); + begin + inherited Create (false); // create NOT suspended + FreeOnTerminate:= false; + FFormParent:= f; + FMax:= AMax; + FTitulek:= napis; + FColor:= AColor; + FLock:= TCriticalSection.Create; + end; + + destructor TwaitProgressThread.Destroy; + begin + FLock.Free; + inherited; + end; + + procedure TwaitProgressThread.Execute; + const _Second = 10_000_000; + var Msg: TMsg; + lBusy: LongInt; + liDueTime: LARGE_INTEGER; + begin + FTimer:= CreateWaitableTimer (nil, true, 'EMPPilaTimer'); + liDueTime.QuadPart:= -2 * _Second; + + FForm:= TwaitFormThread.CreateProgress (nil, FTitulek, FMax, FColor); + FForm.Parent:= FFormParent; + FForm.Position:= poScreenCenter; + FForm.HandleNeeded; + FForm.Show; + FForm.Update; + FForm.Invalidate; + while not(Terminated) do + begin + while (PeekMessage (Msg, 0, 0, 0, PM_REMOVE)) do + begin + if (Msg.Message=WM_QUIT) then + begin + Terminate; + Break; + end; + + TranslateMessage (Msg); + DispatchMessage (Msg); + end; + + if (FTimer<>0) then + SetWaitableTimer (FTimer, TLargeInteger(liDueTime), 0, nil, nil, false); + repeat + lBusy:= MsgWaitForMultipleObjects (1, FTimer, false, INFINITE, QS_ALLINPUT); + until (lBusy=WAIT_OBJECT_0) + end; + + if Assigned(FForm) and FForm.HandleAllocated then + PostMessage(FForm.Handle, WM_CLOSE, 0, 0); + + // Process remaining messages to let the form close properly. + while Assigned(FForm) and FForm.Visible do + begin + while PeekMessage (Msg, 0, 0, 0, PM_REMOVE) do + begin + TranslateMessage (Msg); + DispatchMessage (Msg); + end; + Sleep(10); + end; + end; + + procedure TwaitProgressThread.UpdateProgress (AValue: Integer); + begin + FLock.Enter; + try + if Assigned(FForm) and FForm.HandleAllocated then + // Post a custom message to update the progress. + PostMessage (FForm.Handle, WM_UPDATE_PROGRESS, AValue, 0); + finally + FLock.Leave; + end; + end; + + + + procedure TwaitFormThread.WMUpdateProgress (var Msg: TMessage); + begin + FProgressBar.Position:= Msg.WParam; + if (FProgressBar.Position>=FProgressBar.Max) then + Close; + end; + + constructor TwaitFormThread.CreateProgress (AOwner: TComponent=nil; napis: string=''; progBarMaxSize: Integer = 0; barColor: TColor=clRed); + var lW, lH, lT: integer; + begin + inherited CreateNew (AOwner); + try + lW:= 0; + lH:= 0; + BorderStyle:= bsDialog; + Position:= poOwnerFormCenter; + Width:= 500; + Height:= 25; + + FLabel:= TLabel.Create (self); + with FLabel do + begin + Parent:= self; + Align:= alClient; + Alignment:= taCenter; + Font.Height:= -30; + ParentFont:= false; + Caption:= napis; + lW:= Canvas.TextWidth(Caption); + lH:= Canvas.TextHeight(Caption); + lT:= Top; + end; + Self.Width:= lW + 30; + + FProgressBar:= TProgressBar.Create (self); + with FProgressBar do + begin + Parent:= Self; + AlignWithMargins:= true; + BarColor:= barColor; + Position:= 0; + Top:= lT + lH + 5; + Min:= 0; + Max:= progBarMaxSize; + Width:= Self.Width - 10; + Left:= 5; + Height:= 10; + end; + finally + end; + end; + + + + function waitStart2 (sMsg: string; maxPBar: integer=0; PBarColor: TColor=clRed; f: TForm=nil): TwaitProgressThread; + begin + result:= TwaitProgressThread.Create (sMsg, maxPBar, PBarColor); + end; + + function waitEnd2 (thrd: TwaitProgressThread): boolean; + begin + if (Assigned(thrd)) then + begin + thrd.Terminate; + thrd.WaitFor; + thrd.Free; + end; + end; + + + + function waitStart (TheParent: TComponent; sMsg: string; maxPBar: integer=1; PBarColor: TColor=clRed): TForm; + var lW, lH, lT: integer; + begin + result:= nil; + if (waitForm=nil) then + begin + waitForm:= TForm.Create(TheParent); + with waitForm do + begin + Position:= poOwnerFormCenter; + width:= 500; + lW:= 0; + lH:= 0; + Height:= 25; + waitLabel:= TLabel.Create(waitForm); + with waitLabel do + begin + Align:= alClient; + Alignment:= taCenter; + Font.Height:= -30; + ParentFont:= false; + Caption:= sMsg; + Parent:= waitForm; + lW:= Canvas.TextWidth(Caption); + lH:= Canvas.TextHeight(Caption); + lT:= Top; + end; + Width:= lW + 30; + if (maxPBar>0) then + begin + waitPBar:= TProgressBar.Create(waitForm); + with waitPBar do + begin + AlignWithMargins:= true; + BarColor:= PBarColor; + Position:= 0; + Top:= lT + lH + 5; + Min:= 0; + Max:= maxPBar; + Width:= waitForm.Width - 10; + Left:= 5; + Height:= 10; + Parent:= waitForm; + end; + end; + SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and not WS_CAPTION); + ClientHeight:= Height; + Show; + Invalidate; + Repaint; + end; + result:= waitForm; + end; + end; + + + + procedure waitSetProgBarMax (maxPBar: integer); + begin + if (maxPBar>0) then + if Assigned(waitPBar) then + waitPBar.Max:= maxPBar; + end; + + + + procedure waitSetProgBar (pozice: integer; wForm: TForm=nil); + var lPB: TProgressBar; + cnt: integer; + cmp: TComponent; + begin + cmp:= nil; + lPB:= TProgressBar.Create (nil); + if (wForm<>nil) then + begin + for cnt:=0 to wForm.ComponentCount-1 do + begin + cmp:= wForm.Components[cnt]; + if (cmp is TProgressBar) then + lPB:= (cmp as TProgressBar); + end; + end; + if (cmp=nil) and (waitPBar<>nil) then + lPB:= waitPBar; + if (pozice>=0) and (lPB<>nil) then + if (lPB.Max>=pozice) then + begin + try + lPB.Position:= pozice; + if (lPB.Parent<>nil) then + lPB.Parent.Invalidate; + except + end; + end; + FreeAndNil (lPB); + end; + + + + procedure WaitSetMsg (sMsg: string ); + begin + WaitLabel.Caption:= sMsg; + WaitForm.Width:= waitLabel.Width + 10; + WaitForm.Invalidate; + end; + + + + function waitEnd (wForm: TForm=nil): boolean; + begin + result:= false; + if (wForm<>nil) then + begin + FreeAndNil (wForm); + result:= true; + end + else + if (waitForm<>nil) then + begin + FreeAndNil (waitForm); + result:= true; + end; + end; + + + + function GetProcessID (ProcessName:string): integer; + var Handle: THandle; + Process: TProcessEntry32; + GotProcess: boolean; + begin + Handle:= CreateToolHelp32SnapShot(TH32CS_SNAPALL,0) ; + Process.dwSize:= SizeOf(Process); + GotProcess:= Process32First(Handle,Process); + {$B-} + if GotProcess and (LowerCase(Process.szExeFile)<>LowerCase(ProcessName)) then + repeat + GotProcess := Process32Next(Handle,Process); + until (not GotProcess) or (LowerCase(Process.szExeFile)=LowerCase(ProcessName)); + {$B+} + if GotProcess then + Result := Process.th32ProcessID + else + Result := 0; + CloseHandle(Handle); + end; + + + + function GetPathFromPID(const PID: cardinal): string; + var hProcess: THandle; + path: array[0..MAX_PATH - 1] of char; + begin + hProcess:= OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, PID); + if (hProcess<>0) then + try + if GetModuleFileNameEx(hProcess, 0, path, MAX_PATH) = 0 then + RaiseLastOSError; + Result:= path; + finally + CloseHandle(hProcess) + end + else + RaiseLastOSError; + end; + + + + function GetWidthText(const Text:String; Font:TFont) : Integer; + var LBmp: TBitmap; + begin + LBmp := TBitmap.Create; + try + LBmp.Canvas.Font := Font; + result := LBmp.Canvas.TextWidth(Text); + finally + LBmp.Free; + end; + end; + + + function StrListRemoveEmpty(strList: TStringList): boolean; + var i: integer; + begin + result:= true; + try + for i:=strList.Count-1 downto 0 do + begin + if Trim(strList[i]) = '' then + strList.Delete(i); + end; + except + result:= false; + end; + end; + + + + + function RandomString (const aLength: byte; const startWith: string=''): string; + const ACharSequence = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890'; + var Ch, SequenceLength: Integer; + begin + SequenceLength := Length(ACharSequence); + SetLength(Result, ALength); + Randomize; + for Ch:=Low(Result) to High(Result) do + Result[Ch]:= ACharSequence.Chars[Random(SequenceLength)]; + result:= startWith + result; + end; + + + + + function sStrIndex(const S: string; const List: TArray): integer; + var i: integer; + begin + Result := -1; + for i:= Low(List) to High(List) do + begin + if (CompareText(LowerCase(S), LowerCase(List[i]))=0) then + begin + Result:= i; + Break; + end; + end; + end; + + + + function StrIndex(const S: string; const List: TArray): integer; + var i: integer; + begin + Result := -1; + for i:= Low(List) to High(List) do + begin + if (CompareText(LowerCase(S), LowerCase(List[i]))=0) then + begin + Result:= i; + Break; + end; + end; + end; + + + function VarToBool(V: Variant): Boolean; + begin + if VarIsNull(V) or VarIsEmpty(V) or (V=false) then + result:= false + else + result:= true; + end; + + + function SplitString(const aSeparator, aString: String; aMax: Integer = 0): TArray; + var i, strt, cnt: Integer; + sepLen: Integer; + + procedure AddString(aEnd: Integer = -1); + var endPos: Integer; + begin + if (aEnd = -1) then + endPos := i + else + endPos := aEnd + 1; + if (strt < endPos) then + result[cnt] := Copy(aString, strt, endPos - strt) + else + result[cnt] := ''; + Inc(cnt); + end; + + begin + if (aString = '') or (aMax < 0) then + begin + SetLength(result, 0); + Exit; + end; + + if (aSeparator = '') then + begin + SetLength(result, 1); + result[0] := aString; + Exit; + end; + sepLen := Length(aSeparator); + SetLength(result, (Length(aString) div sepLen) + 1); + i := 1; + strt := i; + cnt := 0; + while (i <= (Length(aString)- sepLen + 1)) do + begin + if (aString[i] = aSeparator[1]) then + if (Copy(aString, i, sepLen) = aSeparator) then + begin + AddString; + + if (cnt = aMax) then + begin + SetLength(result, cnt); + Exit; + end; + + Inc(i, sepLen - 1); + strt := i + 1; + end; + + Inc(i); + end; + AddString(Length(aString)); + SetLength(result, cnt); + end; + + + + function GetSpecialFolderPath(Folder: integer): string; + const SHGFP_TYPE_CURRENT = 0; + var path: array [0..MAX_PATH] of char; + begin + if SUCCEEDED(SHGetFolderPath(0, Folder, 0, SHGFP_TYPE_CURRENT, @path[0])) then + Result := path + else + Result := ''; + end; + + + + function LastPos(const SubStr: String; const S: String): Integer; + begin + result:= Pos(ReverseString(SubStr), ReverseString(S)) ; + if (result<>0) then + result:= ((Length(S) - Length(SubStr)) + 1) - result + 1; + end; + + + + function VyberAdresar(var Foldr: string; Title: string): Boolean; + var BrowseInfo: TBrowseInfo; + ItemIDList: PItemIDList; + DisplayName: array[0..MAX_PATH] of Char; + winDesktop: string; + fldDesktop: PItemIDList; +// callback funkce + function BrowseCallbackProc (hwnd: HWND; uMsg: UINT; lParam: Cardinal; lpData: Cardinal): Integer; stdcall; + var PathName: array[0..MAX_PATH] of Char; + begin + case uMsg of + BFFM_INITIALIZED: + SendMessage(Hwnd, BFFM_SETSELECTION, Ord(True), Integer(lpData)); +{ + BFFM_SELCHANGED: + begin + SHGetPathFromIDList(PItemIDList(lParam), @PathName); + SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, Longint(PChar(@PathName))); + end; +} + end; + result:= 0; + end; + begin + result:= false; + FillChar(BrowseInfo, SizeOf(BrowseInfo), #0); + with BrowseInfo do + begin + hwndOwner := Application.Handle; + pszDisplayName:= @DisplayName[0]; + lpszTitle:= PChar(Title); + ulFlags:= BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE + BIF_USENEWUI + BIF_NONEWFOLDERBUTTON; + + winDesktop:= GetEnvironmentVariable('USERPROFILE') + '\Desktop'; + if (Foldr=winDesktop) then + begin + if (Succeeded(SHGetSpecialFolderLocation (hwndOwner, CSIDL_DESKTOPDIRECTORY, fldDesktop))) then + pidlRoot:= fldDesktop; +// lpfn:= @BrowseCallbackProc; + end; + end; + + ItemIDList:= SHBrowseForFolder(BrowseInfo); + if Assigned(ItemIDList) then + if SHGetPathFromIDList(ItemIDList, DisplayName) then + begin + foldr:= DisplayName; + result:= True; + end; + end; + + + + procedure DeleteGridRow(Grid: TStringGrid; ARow: integer); + var i: integer; + begin + for i:=ARow to Grid.RowCount-2 do + Grid.Rows[i].Assign(Grid.Rows[i+1]); + Grid.RowCount:= Grid.RowCount-1; + end; + + + + function PosCount(substr, Strg: string): integer; + begin + result:= Length(Strg) - Length(StringReplace(Strg,substr,'',[rfReplaceAll])); + end; + + + + function PosCount2(const SubStr, s: string): integer; + var offset: integer; + begin + result:= 0; + offset:= PosEx(SubStr, s, 1); + while (offset>0) do + begin + inc(result); + offset:= PosEx(SubStr, s, offset + Length(SubStr)); + end; + end; + + + + function PosNthString (const AStr, ASubStr: string; n: integer): integer; + var i, startPos: integer; + begin + result:= 0; + startPos:= 1; + if (n<=0) or (ASubStr='') then + Exit; + + for i:=1 to N do + begin + startPos:= Pos (ASubStr, AStr, startPos); + if (startPos>0) then + begin + if (i=n) then + begin + result:= startPos; + Exit; + end; + startPos:= startPos + Length(ASubStr); + end + else + begin + result:= 0; + Exit; + end; + end; + end; + + + + function ZmenNText (oVar: OleVariant): string; + begin + result:= MidStr(LeftStr(VarToStr(oVar),Length(VarToStr(oVar))-1),3,255); + end; + + + + function OtevriSoubor (const titulek,filtrTit,filtrMask: string; defDir: String; var nazev: String): Boolean; + var dlgOpenXP: TOpenDialog; // dialog pro Windows XP + dlgOpenW7: TFileOpenDialog; // dialog pro Windows Vista a novejsi + begin + nazev:= ''; + result:= false; + try + if (defDir='') then + defDir:= GetEnvironmentVariable('USERPROFILE') + '\Desktop'; + +// test jestli je to Windows nebo + if (GetProcAddress(GetModuleHandle('kernel32'),'GetLocaleInfoEx')<>nil) then + begin + dlgOpenW7:= TFileOpenDialog.Create(nil); + dlgOpenW7.Title:= titulek; + dlgOpenW7.OkButtonLabel:= 'Vybrat'; + with dlgOpenW7.FileTypes.Add do + begin + DisplayName:= filtrTit; + FileMask:= filtrMask; + end; + dlgOpenW7.DefaultFolder:= defDir; + if dlgOpenW7.Execute then + begin + nazev:= dlgOpenW7.FileName; + result:= true; + end; + dlgOpenW7.Free; + end + else + begin + dlgOpenXP:= TOpenDialog.Create(nil); + dlgOpenXP.Title:= titulek; + dlgOpenXP.Filter:= filtrTit + '|' + filtrMask; + dlgOpenXP.InitialDir:= defDir; + if dlgOpenXP.Execute then + begin + nazev:= dlgOpenXP.FileName; + result:= true; + end; + dlgOpenXP.Free; + end; + finally + end; + end; + + + + + + function GetFileVersion2(sFileName:string): string; + var VerInfoSize: DWORD; + VerInfo: Pointer; + VerValueSize: DWORD; + VerValue: PVSFixedFileInfo; + Dummy: DWORD; + iLasterror: DWORD; + begin + VerInfoSize := GetFileVersionInfoSize (PChar(sFileName), Dummy); + + if (VerInfoSize>0) then + begin + + GetMem(VerInfo, VerInfoSize); + GetFileVersionInfo(PChar(sFileName), 0, VerInfoSize, VerInfo); + VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize); + with VerValue^ do + begin + Result := IntToStr(dwFileVersionMS shr 16); + Result := Result + '.' + IntToStr(dwFileVersionMS and $FFFF); + Result := Result + '.' + IntToStr(dwFileVersionLS shr 16); + Result := Result + '.' + IntToStr(dwFileVersionLS and $FFFF); + end; + FreeMem(VerInfo, VerInfoSize); + end + else + begin + iLastError := GetLastError; + Result := Format('GetFileVersionInfo failed: (%d) %s', [iLastError, SysErrorMessage(iLastError)]); + end; + end; + + + + + function IfNull( const Value, Default : OleVariant ) : OleVariant; + begin + if Value = NULL then + Result:= Default + else + Result:= Value; + end; + + + + + function IsNumeric (const InputVal: string): boolean; + var rCode: integer; + v: Extended; + iVal: string; + begin + iVal:= StringReplace(InputVal, ' ', '', [rfReplaceAll]); + try + Val(iVal, v, rCode); + except + rCode:= 1; + end; + result:= rCode = 0; + end; + + + + + + function ArrayToString (const inArray: TArray; const delim: string; insZero: boolean=false): string; + var i:integer; + begin + i:= 0; + result:= ''; + while (i<=Length(inArray)-1) do + begin + result:= result + IntToStr(inArray[i]) + delim; + Inc(i); + end; + if (result[Length(result)]=delim) then + SetLength(result, Length(result)-1); + if (result='') and (insZero) then + result:= '0'; + end; + + + + function ArrayToString (const inArray: TArray; const delim: string; insZero: boolean=false): string; + var i:integer; + begin + i:= 0; + result:= ''; + while (i<=Length(inArray)-1) do + begin + result:= result + FloatToStr(inArray[i]) + delim; + Inc(i); + end; + if (result[Length(result)]=delim) then + SetLength(result, Length(result)-1); + if (result='') and (insZero) then + result:= '0'; + end; + + + + + function RemoveStringArrayItemsStartsWith (const inArray: TArray; const startText: string): TArray; + begin + result:= TArray.Map (inArray, function (var S: string; Index: integer): Boolean + begin + result:= not StartsText (startText, S); + end); + end; + + + + + function StrToArrayInt (aStr: string; const delim: string=','): TArray; + var idx: integer; + a: TArray; + begin + if (aStr<>'') then + idx:= 1 + (Length(aStr) - Length(aStr.Replace(delim, '', [rfReplaceAll]))); // pocet polozek + if (Pos(delim, aStr)=0) then + idx:= 1; + SetLength(a,idx); + for idx:=0 to High(a) do + begin + if Pos(delim, aStr)>0 then + begin + a[idx]:= StrToInt(LeftStr(aStr, Pos(delim, aStr)-1)); + aStr:= MidStr(aStr, Pos(delim, aStr) + 1, Length(aStr)); + end + else + a[idx]:= StrToInt(aStr); + end; + result:= a; + end; + + + + + function StrToHex (S: AnsiString): AnsiString; + var I, Q: Integer; + begin + Q:= length(S); + result:= ''; + for I:=1 to Q do + result:= result + IntToHex(ord(S[i]),2); + end; + + + + function xHexToDec (Hexadecimal: string): cardinal; + var I, Koef: cardinal; + Hex: string [8]; + const HexaChars = '123456789ABCDEF'; + begin + Hex:= UpperCase (Hexadecimal); + Koef:= 1; + result:= 0; + for I:=1 to Length (Hex) do + begin + result:= result + Koef * cardinal(Pos (Hex[Length (Hex)-I+1],HexaChars)); + Koef:= Koef * 16; + end; + end; + + + + function xDecToBin (Decimal: cardinal): string; + var D, M: cardinal; + const BinChars = '01'; + begin + D:= Decimal; + result:= ''; + while D>0 do + begin + M:= D mod 2; + D:= D div 2; + result:= BinChars[M+1] + result; + end; + if Decimal=0 then + result:= '0'; + end; + + + + function xHexToBin (Hexadecimal: string): string; + begin + result:= xDecToBin (xHexToDec (Hexadecimal)); + end; + + + + function HexToMemoryStream (AString: string): TMemoryStream; + var i: Integer; + MemStream: TMemoryStream; + ByteValue: Byte; + begin + result:= nil; + MemStream:= TMemoryStream.Create; + try + // Make sure the string length is even + if (Length(AString) mod 2 <> 0) then + Exit; + + // Convert hex string to bytes and write to memory stream + for i := 1 to Length(AString) div 2 do + begin + // Extract each pair of hex digits + ByteValue := StrToInt ('$' + AString.Substring((i-1)*2, 2)); + MemStream.Write(ByteValue, SizeOf(ByteValue)); + end; + MemStream.Position := 0; // Reset stream position + result:= MemStream; + except + MemStream.Free; + end; + end; + + + + + function StringToMemoryStream(const AString: string): TMemoryStream; + var M: TMemoryStream; + begin + result:= nil; + M:= TMemoryStream.Create; + try + M.Size:= (Length(AString)*SizeOf(Char)) div 2; + if (M.Size>0) then + begin + HexToBin(PChar(AString), M.Memory, M.Size); + M.Position:= 0; + end; + finally + Result:= M; +// M.Free; + end; + end; + + + + + function MemStreamToHex(aStream: TMemoryStream): string; + var i: integer; + b: byte; + begin + result:= ''; + for i:=0 to aStream.Size-1 do + begin + b:= PByte(TMemoryStream(aStream).Memory)[i]; + result:= result + IntToHex(b,2); + end; + end; + + + + + function HexToString (H: AnsiString): AnsiString; +{ var I,L: Integer; + begin + result:= ''; + L:= length(H); + for I:= 1 to L div 2 do + result:= result + Char(StrToInt('$'+Copy(H,(I-1)*2+1,2))); + end; +} + const Convert: array['0'..'f'] of byte = + (0, 1, 2, 3, 4, 5, 6, 7, 8, 9,16,16,16,16,16,16, + 16,10,11,12,13,14,15,16,16,16,16,16,16,16,16,16, + 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, + 16,10,11,12,13,14,15); + var FPos, Check, len, len2: Integer; + ch: AnsiChar; + begin + FPos:= 0; + Check:= 0; + len:= Length(H); + len2:= len div 2; + SetLength(Result, len2); + if len < 2 then Exit; {Too small} + repeat + ch := H[2*FPos+1]; + if (not(ch in['0'..'f']))or(Convert[ch]>15) then break; + Result[FPos+1]:= AnsiChar((Convert[ch] shl 4)); + ch:= H[2*FPos+2]; + if (not(ch in['0'..'f']))or(Convert[ch]>15) then break; + inc(FPos); + Result[FPos]:= AnsiChar(ord(Result[FPos])+Convert[ch]); + Check:= Check + ord(Result[FPos]); + Dec(len2); + until (len2=0); + SetLength(Result, FPos); + end; + + + + function FileToHex(fName: string): string; + var mStr: TMemoryStream; + begin + result:= '0'; + if (FileExists(fName)) then + begin + mStr:= TMemoryStream.Create; + try + mStr.LoadFromFile(fName); + if (mStr.Size>0) then + result:= MemStreamToHex(mStr); + except + end; + mStr.Free; + end; + end; + + + + + function TestFileExclusiveAccess (fName: string; ukazHlasku: Boolean=true): boolean; + var FileHandle: THandle; + Flags: Cardinal; + LastError: Cardinal; + TextErrorCode: PChar; + procedure DisplayNotification; + begin + FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER or + FORMAT_MESSAGE_FROM_SYSTEM, + nil, LastError, LANG_USER_DEFAULT, + @TextErrorCode, 0, nil + ); + ShowMessage (TextErrorCode); + LocalFree (HLOCAL(TextErrorCode)); + end; + begin + result:= False; + + Flags:= GetFileAttributes (PChar(fName)); + if (Flags <> INVALID_FILE_ATTRIBUTES) then + begin + if ((faDirectory and Flags) <> faDirectory) then + begin + FileHandle:= CreateFile (PChar(fName), + GENERIC_READ, FILE_SHARE_READ, + nil, OPEN_EXISTING, 0, 0 + ); + LastError:= GetLastError; + try + if not(FileHandle<>INVALID_HANDLE_VALUE) then + result:= true; + finally + CloseHandle (FileHandle); + end; + + // Notify user about problems with opening the file + if (FileHandle = INVALID_HANDLE_VALUE) and (ukazHlasku) then + DisplayNotification; + end + else + // Notification about specified filename defines a directory not a single file + end + else + begin + // Notify user if there is a problem with getting file's attributes + LastError:= GetLastError; + DisplayNotification; + end; + end; + + + + + function Clipboard2StringArray(const SmazHead: boolean): TArray>; + var cont: boolean; + radky, sTmp, zaznam: string; + cnt,idx,idxS,sloupcu: integer; + resRadky: TArray>; + begin + cont:= true; + radky:= ''; + try + radky:= Clipboard.AsText; + except on E:Exception do + cont:= false; + end; + if (radky<>'') and (cont) then + begin + cnt:= myUtils.PosCount(#13,radky); // pocet radek + radky:= StringReplace(radky, #9#9, #9' '#9, [rfReplaceAll]); + if Pos(Chr(13),radky)>0 then + sTmp:= LeftStr(radky,Pos(#13,radky)-1) + else + sTmp:= radky; + sloupcu:= myUtils.PosCount(#9,sTmp)+1; + if SmazHead then + cnt:= cnt - 1; + SetLength(resRadky,cnt,sloupcu); // pole pro data (pocet po odmazani 1.radku s nadpisy sloupcu) + if cont then + begin + if SmazHead then + Delete(radky,1,Pos(#13,radky)+1); // smaze radek s popisem sloupcu + for idx:= 0 to cnt-1 do + begin + if Pos(#13,radky)>0 then + zaznam:= LeftStr(Trim(radky),Pos(#13,radky)-1) + else + zaznam:= Trim(radky); + for idxS:=0 to sloupcu-1 do + begin +{ if LeftStr(zaznam,1)<>#9 then + Delete(zaznam,1,Pos(#9,zaznam)) + else + zaznam:= MidStr(zaznam,2,65535); + if zaznam=#9 then + zaznam:= ''; } + if Pos(#9,zaznam)>0 then + begin + resRadky[idx,idxS]:= Trim(LeftStr(zaznam,Pos(#9,zaznam)-1)); + Delete(zaznam,1,Pos(#9,zaznam)); + end + else + resRadky[idx,idxS]:= Trim(zaznam); + end; + Delete(radky,1,Pos(#13,radky)+1); + end; + end; + end; + Result:= resRadky; + end; + + + + function RoundToEX(const AValue: Extended; const ADigit: TRoundToEXRangeExtended): Extended; + type TFactors = array[1..2] of Extended; + PFactors = ^TFactors; + var LFactor : PFactors; + CW8087 : Word; + Digits : Integer; + const + LFactorArray : array[-20..20] of TFactors = ( + (1E-20, 1E20), (1E-19, 1E19), (1E-18, 1E18), (1E-17, 1E17), (1E-16, 1E16), + (1E-15, 1E15), (1E-14, 1E14), (1E-13, 1E13), (1E-12, 1E12), (1E-11, 1E11), + (1E-10, 1E10), (1E-09, 1E09), (1E-08, 1E08), (1E-07, 1E07), (1E-06, 1E06), + (1E-05, 1E05), (1E-04, 1E04), (1E-03, 1E03), (1E-02, 1E02), (1E-01, 1E01), + (1, 1), + (1E01, 1E-01), (1E02, 1E-02), (1E03, 1E-03), (1E04, 1E-04), (1E05, 1E-05), + (1E06, 1E-06), (1E07, 1E-07), (1E08, 1E-08), (1E09, 1E-09), (1E10, 1E-10), + (1E11, 1E-11), (1E12, 1E-12), (1E13, 1E-13), (1E14, 1E-14), (1E15, 1E-15), + (1E16, 1E-16), (1E17, 1E-17), (1E18, 1E-18), (1E19, 1E-19), (1E20, 1E-20)); + begin + Digits := ADigit; + if Abs(Digits) > 20 then + raise Exception.Create('ADigit out of range'); + CW8087 := Get8087CW; + try + Set8087CW(4978); + if Digits = 0 then + Result := Round(AValue) + else + begin + LFactor := @LFactorArray[Digits]; + Result := Round(AValue * LFactor[2]) * LFactor[1]; + end; + finally + Set8087CW(CW8087); + end; + end; + + + + function IfThenInt(AValue: Boolean; const ATrue: integer; AFalse: integer = -1): integer; + begin + result:= AFalse; + if (AValue) then + result:= ATrue; + end; + + + + function IfThenExt(AValue: Boolean; const ATrue: extended; AFalse: extended = -1): extended; + begin + result:= AFalse; + if (AValue) then + result:= ATrue; + end; + + + + function IfThenBool(AValue: Boolean; const ATrue: Boolean; AFalse: Boolean = false): Boolean; + begin + result:= AFalse; + if (AValue) then + result:= ATrue; + end; + + + constructor THeliosImages.Create; + var ico: TIcon; + begin + FImageList32:= TImageList.CreateSize(32,32); + FImageList32.ColorDepth:= cd8Bit; + ico:= TIcon.Create; + ico.LoadFromResourceName(hInstance,'ICO_MAIN'); // 0 + FImageList32.AddIcon(ico); + ico.LoadFromResourceName(hInstance,'ICO_PRIOR'); // 1 + FImageList32.AddIcon(ico); + ico.LoadFromResourceName(hInstance,'ICO_NEXT'); // 2 + FImageList32.AddIcon(ico); + ico.LoadFromResourceName(hInstance,'ICO_ADD'); // 3 + FImageList32.AddIcon(ico); + ico.LoadFromResourceName(hInstance,'ICO_EDIT'); // 4 + FImageList32.AddIcon(ico); + ico.LoadFromResourceName(hInstance,'ICO_DEL'); // 5 + FImageList32.AddIcon(ico); + end; + + + destructor THeliosImages.Destroy; + begin + FImageList32.Free; + end; + + + + function UdajeOFirme(const Helios: IHelios; idOrg,cisOrg: integer;var Nazev,ICO,DIC: string): boolean; + var lSQL: string; + begin + result:= false; + + lSQL:= 'SELECT Nazev,ICO,DIC FROM ' + tblCOrg + ' WHERE '; + if idOrg>0 then + lSQL:= lSQL + 'id=' + IntToStr(idOrg); + if cisOrg>=0 then + lSQL:= lSQL + 'CisloOrg=' + IntToStr(cisOrg); + + with Helios.OpenSQL(lSQL) do + if RecordCount>0 then + begin + Nazev:= VarToStr(FieldValues(0)); + ICO:= VarToStr(FieldValues(1)); + DIC:= VarToStr(FieldValues(2)); + result:= true; + end; + end; + + + + function NajdiPrvniVolny(const Helios: IHelios; Tab, Najdi, DruhPoh, RadaDokl, idObd, Podm: string): integer; + var lSQL: string; + idDZshift, idDZ: integer; + begin + result:= 0; + idDZshift:= 0; // posunuti cisla brane z nastaveni TabDruhDokZboDef + lSQL:= 'SELECT dzd.PosledniPC FROM ' + tblDDZdef + ' dzd INNER JOIN ' + tblDDZ + ' dz'; + lSQL:= lSQL + ' ON (dz.ID=dzd.idDruhDZ) WHERE dzd.IdObdobi=' + IdObd; + lSQL:= lSQL + ' AND dz.DruhPohybuZbo=' + DruhPoh + ' AND dz.RadaDokladu=N' + QuotedStr(RadaDokl); + + with Helios.OpenSQL(lSQL) do + if not VarIsNull(FieldValues(0)) then + if not TryStrToInt(VarToStr(FieldValues(0)),idDZshift) then + idDZshift:= 0; + + idDZ:= 0; + lSQL:= 'EXEC dbo.hp_NajdiPrvniVolny N' + QuotedStr(Tab) + ',N' + QuotedStr(Najdi); + lSQL:= lSQL + ',' + IntToStr(idDZshift) + ',99999999,N' + QuotedStr(Podm) + ',0,1'; + with Helios.OpenSQL(lSQL) do + if not VarIsNull(FieldValues(0)) then + if not TryStrToInt(VarToStr(FieldValues(0)),idDZ) then + idDZ:= 0; + if (idDZ=0) or (idDZ=idDZshift) then + idDZ:= idDZshift + 1; + + lSQL:= 'EXEC dbo.hp_NajdiPrvniVolny N' + QuotedStr(Tab) + ',N' + QuotedStr(Najdi); + lSQL:= lSQL + ',' + IntToStr(idDZ) + ',99999999,N' + QuotedStr(Podm) + ',0,1'; + with Helios.OpenSQL(lSQL) do + if not VarIsNull(FieldValues(0)) then + if not TryStrToInt(VarToStr(FieldValues(0)),idDZ) then + idDZ:= 0; + + result:= idDZ; + end; + + + procedure ExitColor(Sender: TWinControl) ; + begin + if Sender <> nil then + begin + if IsPublishedProp(Sender,'Color') then + begin + SetOrdProp(Sender,'Color',oldCol) ; + end; + end; + end; + + + + + function ZapisDoKJ(const Helios: IHelios; Kat, Typ, Stav, Vystup, predmet, popis: string): integer; + var lSQL: string; + i: integer; + begin + result:= 0; + i:= 0; + with Helios.OpenSQL('SELECT MAX(PoradoveCislo) FROM ' + tblKJ + ' WHERE Kategorie=N' + QuotedStr(Kat)) do + if not VarIsNull(FieldValues(0)) then + i:= StrToInt(VarToStr(FieldValues(0))); + Inc(i); + lSQL:= 'INSERT ' + tblKJ + ' (DatumJednaniOd,PoradoveCislo,Kategorie,Predmet,Typ,Stav,DruhVystupu,Popis,MistoKonani) VALUES (GETDATE(),' + IntToStr(i); + lSQL:= lSQL + ',N' + QuotedStr(Kat) + ',N' + QuotedStr(predmet) + ',N' + QuotedStr(Typ) + ',N' + QuotedStr(Stav); + lSQL:= lSQL + ',N' + QuotedStr(Vystup) + ',CONVERT(ntext,N' + QuotedStr(popis) + '),N' + QuotedStr('') + ' )' + CRLF + 'SELECT SCOPE_IDENTITY()'; + try + with Helios.OpenSQL(lSQL) do + if not VarIsNull(FieldValues(0)) then + result:= StrToInt(VarToStr(FieldValues(0))); + except on E:Exception do + Helios.Error(#1'Chybu se nepodařilo uložit do Kontaktních jednání (HeO).'#1 + CRLF + E.Message); + end; + end; + + + procedure EnterColor(Sender: TWinControl) ; + begin + if Sender <> nil then + begin + if IsPublishedProp(Sender,'Color') then + begin + oldCol := GetOrdProp(Sender,'Color') ; + SetOrdProp(Sender,'Color', focCol) ; + end; + end; + end; + + + + procedure ScreenActiveControlChange(Sender: TObject) ; + var doEnter, doExit : boolean; + previousActiveControl : TWinControl; + begin + if Screen.ActiveControl = nil then + begin + lastFocused:= nil; + Exit; + end; + doEnter:= true; + doExit:= true; + + //CheckBox + if Screen.ActiveControl is TButtonControl then + doEnter:= false; + + previousActiveControl:= lastFocused; + + if previousActiveControl <> nil then + begin + //CheckBox + if previousActiveControl is TButtonControl then + doExit:= false; + end; + + lastFocused:= Screen.ActiveControl; + + if doExit then + ExitColor(previousActiveControl) ; + if doEnter then + EnterColor(lastFocused) ; + end; + + + + procedure NactiParametryHeliosu(const Helios: IHelios; var pars: THeliosParams); + begin + pars.delkaRC:= 5; + pars.podbarveni:= false; +// pars.colBg:= $FF000000 or COLOR_WINDOW; // clWindow + + if Screen.Fonts.IndexOf('Segoe UI')<>-1 then + pars.FontName:= 'Segoe UI' + else + pars.FontName:= 'Tahoma'; + pars.FontSize:= 8; + + with Helios.OpenSQL('SELECT TOP(1) * FROM ' + tblHGlob + ' ORDER BY id') do + if RecordCount>0 then + pars.delkaRC:= StrToInt(VarToStr(FieldByNameValues('DelkaRegCislaZbozi'))); + + with Helios.OpenSQL('SELECT * FROM ' + tblUziv + ' WHERE LoginName=N' + QuotedStr(Helios.LoginName)) do + if RecordCount>0 then + begin + pars.podbarveni:= StrToBool(VarToStr(FieldByNameValues('BarevnePodbarveni'))); + pars.colBg:= StrToInt(VarToStr(FieldByNameValues('BarvaPodbarveni'))); + end; + + with Helios.OpenSQL('SELECT * FROM ' + tblUserCfg + ' WHERE LoginName=N' + QuotedStr(Helios.LoginName)) do + if RecordCount>0 then + begin + if VarToStr(FieldByNameValues('FontName'))<>'' then + pars.FontName:= VarToStr(FieldByNameValues('FontName')); +// pars.FontSize:= Round(StrToInt(VarToStr(FieldByNameValues('FontSize')))*0.75); + if VarToStr(FieldByNameValues('FontSize'))<>'' then + pars.FontSize:= Round(StrToInt(VarToStr(FieldByNameValues('FontSize')))*1.75); + end; + end; + + + procedure ReseedTable(const Helios: IHelios; tblName:string); + var locSQL: string; + identCol,radka,ttbl: string; + lzeTrunc: boolean; + begin + lzeTrunc:= true; + identCol:= ''; + radka:= ''; + if (PosCount('.',tblName)=2) then + ttbl:= RightStr(tblName,Pos('.',ReverseString(tblName))-1); +{ + case PosCount('.',tblName) of + 1: begin + ttbl:= StringReplace(tblName,'[','',[rfReplaceAll]); + ttbl:= StringReplace(ttbl,']','',[rfReplaceAll]); + ttbl:= StringReplace(ttbl,'.','',[rfReplaceAll]); + ttbl:= MidStr(ttbl,4,50); + end; + end; +} +// 'SELECT ISNULL(Name,N' + QuotedStr('') + ') AS iCol FROM syscolumns WHERE OBJECT_NAME(id)=N' + QuotedStr(tblName) + ' AND COLUMNPROPERTY(id,name,''IsIdentity'')=1'; + with Helios.OpenSQL('SELECT [name] FROM sys.identity_columns WHERE [object_id]=OBJECT_ID(N' + tblName.QuotedString + ',N''U'') AND Is_computed=0 AND Is_identity=1') do + begin + if (RecordCount=1) then + begin + identCol:= Trim(VarToStr(FieldValues(0))); + if (identCol<>'') then + begin + with Helios.OpenSQL('SELECT TOP(1) ' + identCol + ' FROM ' + tblName + ' ORDER BY ' + identCol + ' DESC') do + if (RecordCount>0) then + begin + with Helios.OpenSQL('SELECT ISNULL(MAX(' + identCol + '), 1) FROM ' + tblName) do + radka:= VarToStr(FieldValues(0)); + locSQL:= 'DBCC CHECKIDENT(' + tblName.Replace('[dbo].','').Replace('dbo.','').QuotedString + ', RESEED,' + radka + ')'; + Helios.ExecSQL(locSQL); + end + else + begin +// try +// Helios.ExecSQL('TRUNCATE TABLE ' + tblName); +// except +// end; +// Helios.Refresh(true); + Helios.ExecSQL('DBCC CHECKIDENT(' + tblName.Replace('[dbo].', '').Replace('dbo.', '') + ', RESEED, 1)'); + end; + end; + end; + end; + end; + + + procedure TIntEdit.KeyPress (var Key: Char); + begin + if not CharInSet(Key,['+', '-', '0'..'9', #8,#13]) then + Key := #0 + else + inherited KeyPress(Key); + end; + + + procedure TFloatEdit.KeyPress (var Key: Char); + begin + if not CharInSet(Key,['+', '-', '.', ',' , FormatSettings.DecimalSeparator , '0'..'9', #0..#31]) then + Key := #0 + else + inherited KeyPress(Key); + end; + + +{ + function GetAveCharSize(Canvas: TCanvas): TPoint; + var I: Integer; + Buffer: array[0..51] of Char; + begin + for I:=0 to 25 do + Buffer[I]:= Chr(I + Ord('A')); + for I:=0 to 25 do + Buffer[I+26]:= Chr(I + Ord('a')); + GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result)); + Result.X:= Result.X div 52; + end; +} + + function GetAveCharSize (Canvas: TCanvas): TPoint; + const Buffer: PChar = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; + var tm: TTextMetric; + begin + GetTextMetrics(Canvas.Handle, tm); + GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result)); + Result.X := (Result.X div 26 + 1) div 2; + Result.Y := tm.tmHeight; + end; + + + function FormMnozstviCena (const Title: string; var mnoz,JC: Extended; const JCdleEvid: boolean; const CenaEnabled: boolean): boolean; + var frm: TForm; + lbl1, lbl2: TLabel; + eMnoz, eJC: TEdit; + btnOK, btnCancel: TButton; + DialogUnits: TPoint; + ButtonWidth, ButtonHeight: Integer; + begin + result:= false; + frm:= TForm.Create(nil); + with frm do + try + Canvas.Font:= Font; + DialogUnits:= GetAveCharSize(Canvas); + BorderStyle:= bsDialog; + Caption:= Title; + Font.Size:= 10; + ClientWidth:= MulDiv(180, DialogUnits.X, 4); + ClientHeight:= 150; + Position:= poScreenCenter; + lbl1:= TLabel.Create(frm); + with lbl1 do + begin + Parent:= frm; + Caption:= 'Množství: '; + Left:= MulDiv(8, DialogUnits.X, 4); + Top:= MulDiv(8, DialogUnits.X, 4); + Constraints.MaxWidth:= MulDiv(164, DialogUnits.X, 4); + WordWrap:= True; + end; + lbl2:= TLabel.Create(frm); + with lbl2 do + begin + Parent:= frm; + Caption:= 'Jednotková cena: '; + Left:= MulDiv(8, DialogUnits.X, 4); + Top:= lbl1.Top + lbl1.Height + 10; + Constraints.MaxWidth:= MulDiv(164, DialogUnits.X, 4); + WordWrap:= True; + end; + + eMnoz:= TFloatEdit.Create(frm); + with eMnoz do + begin + Parent:= frm; + Left:= lbl2.Left + lbl2.Width + 25; + Top:= lbl1.Top; + Alignment:= taRightJustify; + Text:= FloatToStr(Mnoz); + end; + eJC:= TFloatEdit.Create(frm); + with eJC do + begin + Parent:= frm; + Left:= lbl2.Left + lbl2.Width + 25; + Top:= lbl2.Top; + Alignment:= taRightJustify; + Text:= FloatToStr(JC); + if not CenaEnabled then + Enabled:= false; + end; + + ButtonWidth := MulDiv(50, DialogUnits.X, 4); + ButtonHeight := MulDiv(14, DialogUnits.Y, 8); + with TButton.Create(frm) do + begin + Parent:= frm; + Caption:= 'OK'; + ModalResult:= mrOK; + Default:= true; + SetBounds(MulDiv(20, DialogUnits.X, 4), 100, ButtonWidth, ButtonHeight); + end; + with TButton.Create(frm) do + begin + Parent:= frm; + Caption:= 'Zrušit'; + ModalResult:= mrCancel; + Cancel:= True; + SetBounds(MulDiv(100, DialogUnits.X, 4), 100, ButtonWidth, ButtonHeight); + end; + + if (ShowModal=mrOK) then + begin + result:= true; + if (Pos(',', eMnoz.Text)>0) and (FormatSettings.DecimalSeparator='.') then + eMnoz.Text:= StringReplace(eMnoz.Text,',','.',[rfReplaceAll]); + if (Pos('.', eMnoz.Text)>0) and (FormatSettings.DecimalSeparator=',') then + eMnoz.Text:= StringReplace(eMnoz.Text,'.',',',[rfReplaceAll]); + mnoz:= StrToFloat(eMnoz.Text); +// mnoz:= StrToFloat(StringReplace(eMnoz.Text,',','.',[rfReplaceAll])); + JC:= StrToFloat(eJC.Text); + if JCdleEvid then + JC:= -1; + end; + finally + frm.Free; + end; + end; + + + + function FormComboBox (const Title, Desc: string; const inStr: TStringList; var cbText: string): boolean; + var frm: TForm; + lbl1: TLabel; + cb: TComboBox; + btnOK,btnCancel: TButton; + DialogUnits: TPoint; + ButtonWidth, ButtonHeight, rNum: Integer; + idx, iWidth, iWidthFull: integer; + const HORIZ_PADDING = 4; + CB_SETDROPPEDWIDTH = 352; + begin + result:= false; + frm:= TForm.Create(nil); + with frm do + try + Canvas.Font:= Font; + Font.Size:= 10; + DialogUnits:= GetAveCharSize(Canvas); + BorderStyle:= bsDialog; + Caption:= Title; + ClientWidth:= MulDiv(200, DialogUnits.X, 4); + ClientHeight:= 120; + Position:= poScreenCenter; + lbl1:= TLabel.Create(frm); + with lbl1 do + begin + Parent:= frm; + Caption:= Desc; + Left:= MulDiv(8, DialogUnits.X, 4); + Top:= MulDiv(8, DialogUnits.X, 4); + Constraints.MaxWidth:= MulDiv(164, DialogUnits.X, 4); + WordWrap:= True; + end; + cb:= TComboBox.Create(frm); + with cb do + begin + Parent:= frm; + Items.AddStrings(inStr); + Top:= lbl1.Top; + Left:= lbl1.Left + lbl1.Width + 10; + Style:= csDropDownList; + + iWidthFull:= 0; + for idx:=0 to cb.Items.Count-1 do + begin + iWidth:= cb.Canvas.TextWidth(cb.Items[idx]); + Inc(iWidth, 2*HORIZ_PADDING); + if (iWidth>iWidthFull) then + iWidthFull:= iWidth; + end; + if (iWidthFull>cb.Width) then + if (cb.DropDownCountiWidthFull) then + iWidthFull:= iWidth; + end; + if (iWidthFull>cb.Width) then + if (cb.DropDownCount0 then + begin + i:= tbl.RecNo; + tbl.First; + while not(tbl.Eof) do + begin + if tbl.FieldByName(pole).asString<>'' then + result:= result + tbl.FieldByName(pole).AsString + ','; + if Length(result)>0 then + if result[1]=',' then + result:= MidStr(result,2,65535); + tbl.Next; + end; + if RightStr(result,1)=',' then + SetLength(result,Length(result)-1); + tbl.RecNo:= i; + end; + end; + + + + + + function CreateUniqueGUIDFileName (sPath, sPrefix, sExtension: string) : string; + var sFileName: string; + Guid: TGUID; + begin + result:= ''; + repeat + SFileName:= ''; + CreateGUID(Guid); + SFileName:= sPath + sPrefix + GUIDtoString(GUID); + result:= ChangeFileExt(sFileName, sExtension) + until not FileExists(result); + end; + + + + + + function getHeliosRowToStringDelim (const Helios: IHelios; const lSQL: string; const delim:char): string; + var r: string; + begin + r:= ''; + if (lSQL<>'') then + begin + try + with Helios.OpenSQL(lSQL) do + begin + First; + while not(EOF) do + begin + r:= r + VarToStr(FieldValues(0)) + delim; + Next; + end; + end; + except + end; + if (RightStr(r,1)=delim) then + r:= LeftStr(r, Length(r)-1); + end; + Result:= r; + end; + + + + + + function getHeliosIntVal (const Helios: IHelios; const defVal: integer; sql: string): Integer; + var i: integer; + errMsg: string; + begin + i:= defVal; + if (sql<>'') then + try + with Helios.OpenSQL(sql) do + if (RecordCount=1) then + if not(VarIsNull(FieldValues(0))) then + TryStrToInt(VarToStr(FieldValues(0)), i); + except on E:Exception do + errMsg:= E.Message; + end; + result:= i; + end; + + + + + function getHeliosRowCount (const Helios: IHelios; sql: string): Integer; + begin + Result:= 0; + if (sql<>'') then + try + with Helios.OpenSQL(sql) do + Result:= RecordCount; + except + end; + end; + + + + function getHeliosDateTimeVal (const Helios: IHelios; const defVal: TDateTime; sql: string): TDateTime; + var i: TDateTime; + begin + i:= defVal; + if (sql<>'') then + try + with Helios.OpenSQL(sql) do + if (RecordCount=1) then + if not(VarIsNull(FieldValues(0))) then + TryStrToDateTime(VarToStr(FieldValues(0)), i); + except + end; + result:= i; + end; + + + + + function getHeliosFloatVal (const Helios: IHelios; const defVal: Extended; sql: string): Extended; + var i: Extended; + errMsg: string; + begin + i:= defVal; + if (sql<>'') then + try + with Helios.OpenSQL(sql) do + if (RecordCount=1) then + if not(VarIsNull(FieldValues(0))) then + TryStrToFloat(VarToStr(FieldValues(0)), i); + except on E: Exception do + errMsg:= E.Message; + end; + result:= i; + end; + + + + + function getHeliosStrVal (const Helios: IHelios; const defVal: string; sql: string): string; + var s, errMsg: string; + begin + s:= defVal; + if (sql<>'') then + try + with Helios.OpenSQL(sql) do + if (RecordCount=1) then + if not(VarIsNull(FieldValues(0))) then + s:= VarToStr(FieldValues(0)); + except on E: Exception do + errMsg:= E.Message; + end; + result:= s; + end; + + + + + function sqlExistsTestGeneral (const Helios: IHelios; SQLText: string): boolean; + var errMsg: string; + begin + result:= false; + SQLText:= Trim(SQLText); + if (SQLText<>'') then + try + with Helios.OpenSQL(SQLText) do + if (RecordCount>0) then + result:= true; + except on E: Exception do + errMsg:= E.Message; + end; + end; + + + + + function sqlSanitize (inText: string): string; + begin + result:= inText.Replace('--', '').Replace(';', '').Replace('''', '').Replace('"', ''); + result:= result.Replace(Chr(64), '').Replace(Chr(35), '').Replace(Chr(37), ''); + end; + + + + + function getSQLTabOrColName (xName: string; returnColName: Boolean=true): string; + var s: string; + begin + result:= xName; + if (xName.Contains('[')) then + begin + result:= helUtils.RemoveTableNamePrefix(xName); + if (xName.Contains('.')) then + begin + if (returnColName) then + result:= MidStr(xName, Pos('.', xName)+1, 255) + else + result:= LeftStr(xName, Pos('.', xName)-1); + end; + end; + end; + + + + + function getSQLInfoSchemaVal(const Helios: IHelios; tabName: string = ''; colName: string = ''; valName: string = ''): string; + var lSQL: string; + begin + result:= ''; + if (tabName.Contains('.')) then + begin + colName:= MidStr(tabName, Pos('.', tabName)+1, 255); + tabName:= LeftStr(tabName, Pos('.', tabName)-1); + end; + + if (tabName<>'') and (colName<>'') and (valName<>'') then + begin + lSQL:= 'SELECT c.' + valName + ' FROM ' + Helios.CurrentDB + '.INFORMATION_SCHEMA.COLUMNS c WHERE c.TABLE_NAME=N' + tabName.QuotedString + ' AND c.COLUMN_NAME=N' + colName.QuotedString + + ' AND c.TABLE_SCHEMA=N''dbo'''; + result:= helUtils.getHeliosStrVal(Helios, '', lSQL).ToUpper; + end; + + end; + + + + + + function getSQLColumnType(const Helios: IHelios; tabName: string = ''; colName: string = ''): string; + begin + result:= helUtils.getSQLInfoSchemaVal(Helios, tabName, colName, 'DATA_TYPE').ToUpper; + end; + + + + + function getSQLColumnDef(const Helios: IHelios; tabName: string = ''; colName: string = ''): string; + var lSQL, r1, r2, r3, isNullableStr: string; + cont: boolean; + begin + result:= ''; + cont:= true; + if (tabName.Contains('.')) then + begin + colName:= MidStr(tabName, Pos('.', tabName)+1, 255); + tabName:= LeftStr(tabName, Pos('.', tabName)-1); + end; + + if (tabName<>'') and (colName<>'') then + begin + result:= helUtils.getSQLColumnType(Helios, tabName, colName).ToUpper; + isNullableStr:= helUtils.getSQLInfoSchemaVal(Helios, tabName, colName, 'IS_NULLABLE').ToUpper; + + if (result='NVARCHAR') or (result='VARCHAR') then + begin + r1:= helUtils.getSQLInfoSchemaVal(Helios, tabName, colName, 'CHARACTER_MAXIMUM_LENGTH').ToUpper; + result:= result + '(' + r1 + ')' + IfThen(isNullableStr<>'YES', 'NOT NULL', ''); + cont:= false; + end; + + if (result='NUMERIC') or (result='FLOAT') or (result='DECIMAL') then + begin + r1:= helUtils.getSQLInfoSchemaVal(Helios, tabName, colName, 'NUMERIC_PRECISION').ToUpper; + r2:= helUtils.getSQLInfoSchemaVal(Helios, tabName, colName, 'NUMERIC_SCALE').ToUpper; + result:= result + '(' + r1 + ', ' + r2 + ')' + IfThen(isNullableStr<>'YES', 'NOT NULL', ''); + cont:= false; + end; + + if (cont) then + result:= result + IfThen(isNullableStr<>'YES', ' NOT NULL', ''); + end; + + end; + + + + function getHeliosQueryIDs (const Helios: IHelios; const sql: string; emptyVal: string='-1'): string; + var i: integer; + begin + result:= ''; + if (sql<>'') then + try + with Helios.OpenSQL(sql) do + begin + First; + while not(EOF) do + begin + result:= result + VarToStr(FieldValues(0)) + ','; + Next; + end; + end; + finally + end; + if (RightStr(result,1)=',') then + result:= LeftStr(Result,Length(result)-1); + if (result='') then + result:= emptyVal; + end; + + + + + + function getHeliosBoolVal(const Helios: IHelios; const defVal: boolean; const sql: string): boolean; + var r: string; + begin + result:= defVal; + try + if (sql<>'') then + with Helios.OpenSQL(sql) do + if (RecordCount=1) then + begin + r:= VarToStr(FieldValues(0)); + if (r='1') or (r='True') or (r='true') or (r='-1') then + result:= true; + if (r='0') or (r='False') or (r='false') then + result:= false; + end; + except + end; + end; + + + + + +// ---------------------------------------------------------------------------------------------------------------------------- +// Returns true if the current process is executing as a 32 bit process under WOW64 on 64 bit Windows + function IsWow64: Boolean; + type TIsWow64Process = function( // Type of IsWow64Process API fn + Handle: Winapi.Windows.THandle; var Res: BOOL): BOOL; stdcall; + var IsWow64Result: BOOL; // Result from IsWow64Process + IsWow64Process: TIsWow64Process; // IsWow64Process fn reference + begin + // Try to load required function from kernel32 + IsWow64Process := Winapi.Windows.GetProcAddress(GetModuleHandle('kernel32.dll'), 'IsWow64Process'); + if Assigned(IsWow64Process) then + begin + // Function is implemented: call it + if not IsWow64Process(GetCurrentProcess, IsWow64Result) then + raise Exception.Create('IsWow64: bad process handle'); + // Return result of function + Result := IsWow64Result; + end + else + // Function not implemented: can't be running on Wow64 + Result := False; + end; + + + + function IsAdmin (Host : string = '') : Boolean; + var H: SC_HANDLE; + begin + if Win32Platform <> VER_PLATFORM_WIN32_NT then + Result := True + else + begin + H := OpenSCManager(PChar(Host), nil, SC_MANAGER_ALL_ACCESS); + Result := H <> 0; + if Result then + CloseServiceHandle(H); + end; + end; + + + + function IsPhysicalKeyboardConnected: Boolean; + var KeyboardType: Integer; + begin + // Get the keyboard type + KeyboardType:= GetKeyboardType(0); + + // If the keyboard type is greater than 0, it indicates a physical keyboard is connected + Result := KeyboardType > 0; + end; + + + + + function IsRemoteSession: Boolean; + var SessionID: DWORD; + begin + result:= ProcessIdToSessionId (GetCurrentProcessId, SessionID) and (SessionID <> 0); + end; + + + + + function DetectRemoteSession: boolean; + const SM_REMOTECONTROL = $2001; // This system metric is used in a Terminal + // Services environment. Its value is nonzero + // if the current session is remotely + // controlled; otherwise, 0. + + SM_REMOTESESSION = $1000; // This system metric is used in a Terminal + // Services environment. If the calling process + // is associated with a Terminal Services + // client session, the return value is nonzero. + // If the calling process is associated with + // the Terminal Server console session, the + // return value is 0. The console session is + // not necessarily the physical console. + var Mode: string; + begin + result := (GetSystemMetrics(SM_REMOTESESSION) <> 0) or (GetSystemMetrics(SM_REMOTECONTROL) <> 0); + +// Test for emulated local/remote mode + if (FindCmdLineSwitch('Session', Mode, True)) then + begin + if (SameText(Mode, 'Remote')) then + result := True + else + if (SameText(Mode, 'Local')) then + result := False; + end; + end; + + + + + function GetClientComputerName (const typ:byte=0): string; + var hServer: THandle; + readedString: PWideChar; + BytesReturned: DWORD; + begin + result:= ''; // 'N/A (Not a Remote Session)'; + + if not(DetectRemoteSession) then + begin + if (typ=1) then + result:= GetEnvironmentVariable('COMPUTERNAME'); + Exit; + end; + + hServer:= WTS_CURRENT_SERVER_HANDLE; + try + if (typ=1) then + begin + if (WTSQuerySessionInformationW(hServer, WTS_CURRENT_SESSION, WTSWinStationName, readedString, BytesReturned)) then + result:= readedString; + end + else + begin + if (WTSQuerySessionInformationW(hServer, WTS_CURRENT_SESSION, WTSApplicationName, readedString, BytesReturned)) then + result:= readedString; + if (result='') then + result:= GetEnvironmentVariable('COMPUTERNAME') + else + begin + if (WTSQuerySessionInformationW(hServer, WTS_CURRENT_SESSION, WTSClientName, readedString, BytesReturned)) then + result:= result + readedString; + if (WTSQuerySessionInformationW(hServer, WTS_CURRENT_SESSION, WTSClientHardwareId, readedString, BytesReturned)) then + result:= result + readedString; + end; + end; + finally + WTSFreeMemory(readedString); + end; + end; + + + + + function IsDirectoryWriteable(const AName: string): Boolean; + var FileName: String; + H: HFile; //THandle; + begin + FileName:= IncludeTrailingPathDelimiter(AName) + 'chk.tmp'; + H:= CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, CREATE_NEW, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0); + result:= (H <> INVALID_HANDLE_VALUE); + if result then + CloseHandle(H); + end; + + + + function PingHost (const HostName: AnsiString; timeoutMs: cardinal=500): boolean; + const rSize = $400; + var WSAData: TWSAData; + e: PHostEnt; + a: PInAddr; + h: THandle; + d: string; + r: array [0 .. rSize - 1] of byte; + i: cardinal; + begin + result:= false; + try + if WSAStartup($0101, WSAData) <> 0 then + raise Exception.Create('WSAStartup'); + + e:= gethostbyname(PAnsiChar(HostName)); + if (e=nil) then + RaiseLastOSError; + if (e.h_addrtype = AF_INET) then + Pointer(a) := e.h_addr^ + else + raise Exception.Create('Name doesn''t resolve to an IPv4 address'); + d:= FormatDateTime('yyyymmddhhnnsszzz', Now); + h:= IcmpCreateFile; + if (h = INVALID_HANDLE_VALUE) then + RaiseLastOSError; + try + i:= IcmpSendEcho(h, a^, PChar(d), Length(d), nil, @r[0], rSize, TimeoutMS); + result:= (i <> 0) and (PEchoReply(@r[0]).Status = 0); + finally + IcmpCloseHandle (h); + end; + + if WSACleanup <> 0 then + raise Exception.Create('WSACleanup'); + except + end; + end; + + + + function NetGetURLProtocol (const URL: string): string; + var ProtocolEndPos: Integer; + begin + ProtocolEndPos:= Pos('://', URL); + if (ProtocolEndPos > 0) then + result:= Lowercase(Copy(URL, 1, ProtocolEndPos - 1)) + else + result:= ''; // No protocol found + end; + + + + function NetGetHostName (myURL: string): string; + var URI: TIdURI; + myhostname: string; + begin + result := ''; + URI:= TIdURI.Create(myurl); + try + myhostname:= URI.Host; // www.mail.example.co.uk + finally + URI.Free; + end; + result:=myhostname; + end; + + + function NetGetHostNameWithProtocol (myURL: string): string; + var URI: TIdURI; + myhostname: string; + begin + result := ''; + URI:= TIdURI.Create(myurl); + try + myhostname:= URI.Protocol + '://' + URI.Host; // https://www.mail.example.co.uk + finally + URI.Free; + end; + result:=myhostname; + end; + + + + function NetGetHostPort (myURL: string): string; + var URI: TIdURI; + myhostport: string; + begin + result := ''; + URI:= TIdURI.Create(myurl); + try + myhostport:= URI.Port; + finally + URI.Free; + end; + result:=myhostport; + end; + + + + + + procedure OrizniBitmapu (const ASourceBitmap: TBitmap; out ACroppedBitmap: TBitmap; BackgroundColor: TColor = clWhite); + var Left, Top, Right, Bottom: Integer; + SourceRect, DestRect: TRect; + begin + // Najděte souřadnice obsahu + NajdiContentBounds (ASourceBitmap, Left, Top, Right, Bottom, BackgroundColor); + + // Pokud je nějaký obsah nalezen... + if (Left <> -1) and (Top <> -1) and (Right <> -1) and (Bottom <> -1) then + begin + // Vypočítejte rozměry ořezaného obrázku + ACroppedBitmap := TBitmap.Create; + ACroppedBitmap.Width := (Right - Left) + 1; + ACroppedBitmap.Height := (Bottom - Top) + 1; + + // Definujte zdrojový a cílový obdélník + SourceRect := Rect(Left, Top, Right + 1, Bottom + 1); // +1 protože TRect.Bottom a .Right jsou exkluzivní + DestRect := Rect(0, 0, ACroppedBitmap.Width, ACroppedBitmap.Height); + + // Zkopírujte data + ACroppedBitmap.Canvas.CopyRect(DestRect, ASourceBitmap.Canvas, SourceRect); + end + else + begin + // Žádný obsah nebyl nalezen, vraťte nil nebo prázdný bitmap + ACroppedBitmap := nil; + end; + end; + + + + + procedure NajdiContentBounds (const ABitmap: TBitmap; out Left, Top, Right, Bottom: Integer; BackgroundColor: TColor = clWhite); + var x, y: Integer; + found: Boolean; + begin + Left := -1; + Top := -1; + Right := -1; + Bottom := -1; + + // 1. Nalezení horního okraje (Top) + found := False; + for y := 0 to ABitmap.Height - 1 do + begin + for x := 0 to ABitmap.Width - 1 do + begin + if ABitmap.Canvas.Pixels[x, y] <> BackgroundColor then + begin + Top := y; + found := True; + Break; + end; + end; + if found then + Break; + end; + + // 2. Nalezení dolního okraje (Bottom) + found := False; + for y := ABitmap.Height - 1 downto 0 do + begin + for x := 0 to ABitmap.Width - 1 do + begin + if ABitmap.Canvas.Pixels[x, y] <> BackgroundColor then + begin + Bottom := y; + found := True; + Break; + end; + end; + if found then + Break; + end; + +// 3. Nalezení levého okraje (Left) + found := False; + for x := 0 to ABitmap.Width - 1 do + begin + for y := 0 to ABitmap.Height - 1 do + begin + if ABitmap.Canvas.Pixels[x, y] <> BackgroundColor then + begin + Left := x; + found := True; + Break; + end; + end; + if found then + Break; + end; + +// 4. Nalezení pravého okraje (Right) + found := False; + for x := ABitmap.Width - 1 downto 0 do + begin + for y := 0 to ABitmap.Height - 1 do + begin + if ABitmap.Canvas.Pixels[x, y] <> BackgroundColor then + begin + Right := x; + found := True; + Break; + end; + end; + if found then + Break; + end; + end; + +end. diff --git a/frmKeyb.pas b/frmKeyb.pas index 91c8f1d..30933c6 100644 --- a/frmKeyb.pas +++ b/frmKeyb.pas @@ -11,8 +11,7 @@ type keyb1: TTouchKeyboard; edtPopis: TEdit; procedure FormShow (Sender: TObject); - procedure edtPopisKeyDown(Sender: TObject; var Key: Word; - Shift: TShiftState); + procedure edtPopisKeyDown (Sender: TObject; var Key: Word; Shift: TShiftState); private public text: string; @@ -20,6 +19,7 @@ type var formKeyb: TformKeyb; + kbdLayout: TTouchKeyboardLayout; implementation @@ -45,6 +45,20 @@ implementation procedure TformKeyb.FormShow (Sender: TObject); begin + kbdLayout:= TTouchKeyboardLayout.Create; + + with TTouchKeyboardButton.Create do + begin + Text := 'A'; + Caption := 'A'; + SetBounds(10, 10, 50, 50); + ButtonType := TTouchKeyboardButtonType.kbChar; + kbdLayout.Buttons.Add(Self); + end; + + + keyb1.Keyboard:= kbdLayout; + edtPopis.Text:= ''; edtPopis.SetFocus; end;