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.