TomBuzin/EMPolar-plgEMPDeleniTrubek
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
d3bfcc88d6c22c85e02a1e1555dd4874369adb53
EMPolar-plgEMPDeleniTrubek/empUtils.pas

4835 lines
133 KiB
ObjectPascal
Raw Blame History

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>): 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<T> = 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<string>): Integer;
function VlozRadekPohybuZbozi(const Helios: IHelios; idDZ, idSS: integer; sz, regCis: string; mnoz, jc: Extended): integer;
/// <summary>
/// Funkce pro zaokrouhledn<64> na dan<61> po<70>et desetin<69>ch m<>st
/// </summary>
/// <param name="AValue">
/// Hodnota pro zaokrouhledn<64>
/// </param>
/// <param name="ADigit">
/// Po<50>et desetin<69>ch m<>st
/// </param>
/// <remarks>
/// <para>
/// RoundToEx(125.251,2) -&gt; 125.25
/// </para>
/// <para>
/// RoundToEx(125.251,-2) -&gt; 126
/// </para>
/// </remarks>
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;
/// <summary>
/// Funkce pro reseed tabulky s Identity indexem (DBCC CHECKIDENT)
/// </summary>
/// <param name="Helios">
/// IHelios
/// </param>
/// <param name="tblName">
/// N<>zev tabulky
/// </param>
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;
/// <summary>
/// Spust<73> nad Heliosem SQL dotaz a vr<76>t<EFBFBD> String v<>sledek
/// </summary>
/// <param name="Helios">
/// interface IHelios
/// </param>
/// <param name="defVal">
/// defaultne vracena hodnota, pokud SQL dotaz nic nenajde
/// </param>
/// <param name="sql">
/// text SQL p<><70>kazu
/// </param>
/// <returns>
/// STRING hodnota
/// </returns>
function getHeliosStrVal(const Helios: IHelios; const defVal: string; sql: string): string;
/// <summary>
/// Spust<73> nad Heliosem SQL dotaz a vr<76>t<EFBFBD> String v<>sledek
/// </summary>
/// <param name="Helios">
/// interface IHelios
/// </param>
/// <param name="defVal">
/// defaultne vracena hodnota, pokud SQL dotaz nic nenajde
/// </param>
/// <param name="sql">
/// text SQL p<><70>kazu
/// </param>
/// <returns>
/// STRING hodnota
/// </returns>
function getHeliosDateTimeVal(const Helios: IHelios; const defVal: TDateTime; sql: string): TDateTime;
/// <summary>
/// Spust<73> nad Heliosem SQL dotaz a vr<76>t<EFBFBD> DATETIME v<>sledek
/// </summary>
/// <param name="Helios">
/// interface IHelios
/// </param>
/// <param name="defVal">
/// defaultne vracena hodnota, pokud SQL dotaz nic nenajde
/// </param>
/// <param name="sql">
/// text SQL p<><70>kazu
/// </param>
/// <returns>
/// FLOAT hodnota
/// </returns>
function getHeliosFloatVal(const Helios: IHelios; const defVal: Extended; sql: string): Extended;
/// <summary>
/// Spust<73> nad Heliosem SQL dotaz a vr<76>t<EFBFBD> FLOAT/EXTENDED v<>sledek
/// </summary>
/// <param name="Helios">
/// interface IHelios
/// </param>
/// <param name="defVal">
/// defaultne vracena hodnota, pokud SQL dotaz nic nenajde
/// </param>
/// <param name="sql">
/// text SQL p<><70>kazu
/// </param>
/// <returns>
/// INT hodnota
/// </returns>
function getHeliosIntVal (const Helios: IHelios; const defVal: integer; sql: string): Integer;
/// <summary>
/// Spust<73> nad Heliosem SQL dotaz a vr<76>t<EFBFBD> po<70>et <20><>dk<64> jako INT v<>sledek
/// </summary>
/// <param name="Helios">
/// interface IHelios
/// </param>
/// <param name="sql">
/// text SQL p<><70>kazu
/// </param>
/// <returns>
/// INT hodnota
/// </returns>
function getHeliosRowCount (const Helios: IHelios; sql: string): Integer;
function sqlExistsTestGeneral (const Helios: IHelios; SQLText: string): boolean;
function sqlSanitize (inText: string): string;
/// <summary>
/// Z FireDAC tabulky t<><74>dy TFDMemTable ulo<6C><6F> hodnoty zadan<61>ho<68>sloupce do String-u
/// </summary>
/// <param name="tbl">
/// Tabulka typu TFDMemTable
/// </param>
/// <param name="pole">
/// N<>zev sloupce
/// </param>
/// <returns>
/// Hodnoty ze sloupce (odd<64>len<65> <20><>rkou)
/// </returns>
function IDckaTabulky(const tbl: TFDMemTable; pole: string): string;
/// <param name="Helios">
/// IHelios
/// </param>
/// <param name="Tab">
/// N<>zev tabulky
/// </param>
/// <param name="Najdi">
/// N<>zev sloupce jeho<68> hodnotu hled<65>me
/// </param>
/// <param name="DruhPoh">
/// Druh pohybu zbo<62><6F>
/// </param>
/// <param name="RadaDokl">
/// ءda doklad<61>
/// </param>
/// <param name="idObd">
/// Obdob<6F> dokladu
/// </param>
/// <param name="Podm">
/// Dal<61><6C> podm<64>nka podle kter<65> hledat
/// </param>
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;
/// <summary>
/// Zjist<73> <20>daje o firm<72> (N<>zev,Iȏ,DIȩ podle zadan<61>ho idOrg nebo CisloOrg
/// </summary>
/// <param name="Helios">
/// IHelios
/// </param>
/// <param name="Nazev">
/// Vr<56>cen<65> n<>zev organizace
/// </param>
/// <param name="ICO">
/// Vr<56>cen<65> Iȏ
/// </param>
/// <param name="DIC">
/// Vr<56>cen<65> DI<44>
/// </param>
function UdajeOFirme(const Helios: IHelios; idOrg,cisOrg: integer; var Nazev,ICO,DIC: string): boolean;
/// <summary>
/// Kop<6F>ruje z clipboardu hodnoty do pole String
/// </summary>
/// <param name="SmazHead">
/// P<><50>znak jestli se m<> smazat prvn<76> importovan<61> <20><>dek, kde b<>v<EFBFBD> obvykle hlavi<76>ka s n<>zvy sloupc<70>
/// </param>
function Clipboard2StringArray (const SmazHead: boolean): TArray<TArray<string>>;
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;
/// <summary>
/// Najde N-tou pozici ASubStr v AStr
/// </summary>
/// <param name="AStr">
/// Prohledavany text
/// </param>
/// <param name="ASubStr">
/// Hledany text
/// </param>
/// <param name="N">
/// Hledana pozice
/// </param>
function PosNthString (const AStr, ASubStr: string; n: integer): integer;
procedure DeleteGridRow (Grid: TStringGrid; ARow: integer);
/// <summary>
/// Funkce pro p<>evod pole typu TArray(int/extended) do prom<6F>nn<6E> typu string
/// </summary>
/// <param name="inArray">
/// Vstupn<70> pole
/// </param>
/// <param name="delim">
/// Odd<64>lova<76> hodnot
/// </param>
/// <returns>
/// String
/// </returns>
function ArrayToString (const inArray: TArray<integer>; const delim: string; insZero: boolean=false): string; overload;
function ArrayToString (const inArray: TArray<extended>; const delim: string; insZero: boolean=false): string; overload;
function RemoveStringArrayItemsStartsWith (const inArray: TArray<string>; const startText: string): TArray<string>;
function FindInArray (const inArr: TArray<integer>; const i: integer): integer; overload;
function FindInArray (const inArr: TArray<string>; 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<integer>;
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;
/// <summary>
/// V textov<6F> prom<6F>nn<6E> najde posledn<64> pozici vybran<61>ho textu
/// </summary>
/// <param name="SubStr">
/// Hledan<61> <20>et<65>zec
/// </param>
/// <param name="S">
/// Prohled<65>van<61> <20>et<65>zec
/// </param>
/// <returns>
/// Integer - index za<7A><61>tku hledan<61>ho <20>et<65>zce
/// </returns>
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<string>;
function StrIndex (const S: string; const List: TArray<string>): integer;
function sStrIndex (const S: string; const List: TArray<string>): 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;
/// <summary>
/// Vytvori infookno s progress barem v novem threadu
/// </summary>
function waitStart (TheParent: TComponent; sMsg: string; maxPBar: integer=1; PBarColor: TColor=clRed): TForm;
/// <summary>
/// Nastavi maximum progress baru
/// </summary>
procedure waitSetProgBarMax (maxPBar: integer);
/// <summary>
/// Nastavi hlasku infookna
/// </summary>
procedure waitSetMsg (sMsg: string);
/// <summary>
/// Nastavi pozici progress baru
/// </summary>
procedure waitSetProgBar (pozice: integer; wForm: TForm=nil);
/// <summary>
/// Ukonci info okno (thread)
/// </summary>
function waitEnd (wForm: TForm=nil): boolean;
function CreateUniqueGUIDFileName(sPath, sPrefix, sExtension: string) : string;
/// <summary>
/// Vrati prvni index z comboboxu, u ktereho text zacina na dany string
/// </summary>
/// <param name="cbox">
/// Prohledavany ComboBox
/// </param>
/// <param name="S">
/// Hledany string ze zacatku textu
/// </param>
/// <returns>
/// Index (int), pokud nenajde vrati -1
/// </returns>
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>): string;
function RemoveNumbers (const AString: string): string;
function RemoveAlphas (const AString: string): string;
function getHeliosQuery (const Helios:IHelios; const sqlQuery: string): TArray<TArray<string>>;
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 (aInt<self) and (bInt>self) 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<T> }
class function TArrayUtils<T>.Contains(const x: T; const anArray: array of T): boolean;
var y : T;
lComparer: IEqualityComparer<T>;
begin
lComparer := TEqualityComparer<T>.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<string): string;
var iFirst, iLast: integer;
begin
Result:= Text;
if MatchText(Text, Words) then
begin
iFirst:= Low(Words);
iLast:= High(Words);
while (First<=iLast) do
begin
Result:= StringReplace(Result, Words[iFirst], '', [rfReplaceAll, rfIgnoreCase]);
Inc(iFirst);
end;
end;
end;
class function StringHelper.RemoveNumbers: string;
var i, j: integer;
begin
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;
class function StringHelper.RemoveAlphas: string;
var i, j: integer;
begin
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 GetAppVersionStr: string;
var Rec: LongRec;
begin
Rec:= LongRec(GetFileVersion(ParamStr(0)));
Result:= Format('%d.%d', [Rec.Hi, Rec.Lo])
end;
}
function GetAppVersionStr: string;
var Exe: string;
Size, Handle: DWORD;
Buffer: TBytes;
FixedPtr: PVSFixedFileInfo;
begin
Exe:= ParamStr(0);
Size:= GetFileVersionInfoSize(PChar(Exe), Handle);
if Size = 0 then
RaiseLastOSError;
SetLength(Buffer, Size);
if not GetFileVersionInfo(PChar(Exe), Handle, Size, Buffer) then
RaiseLastOSError;
if not VerQueryValue(Buffer, '\', Pointer(FixedPtr), Size) then
RaiseLastOSError;
Result:= Format('%d.%d.%d.%d',
[LongRec(FixedPtr.dwFileVersionMS).Hi, //major
LongRec(FixedPtr.dwFileVersionMS).Lo, //minor
LongRec(FixedPtr.dwFileVersionLS).Hi, //release
LongRec(FixedPtr.dwFileVersionLS).Lo]) //build
end;
function NajdiBID(const Helios: IHelios; bidName: string): integer;
begin
result:= 0;
bidName:= TRegEx.Replace(bidName, '[;,''"]', '').Trim;
if (bidName<>'') 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<TArray<string>>;
var retArr: TArray<TArray<string>>;
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>): 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<integer>; 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<string>; 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<string>): 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<string>): 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<string>): 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<string>;
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 <XP> nebo <Vista a vyssi>
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<integer>; 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<Extended>; 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<string>; const startText: string): TArray<string>;
begin
result:= TArray.Map<string> (inArray, function (var S: string; Index: integer): Boolean
begin
result:= not StartsText (startText, S);
end);
end;
function StrToArrayInt (aStr: string; const delim: string=','): TArray<integer>;
var idx: integer;
a: TArray<integer>;
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<TArray<string>>;
var cont: boolean;
radky, sTmp, zaznam: string;
cnt,idx,idxS,sloupcu: integer;
resRadky: TArray<TArray<string>>;
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<64>ilo ulo<6C>it do Kontaktn<74>ch jedn<64>n<EFBFBD> (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<6E>stv<74>: ';
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<6F> 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<72>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.DropDownCount<cb.Items.Count) then
iWidthFull:= iWidthFull + GetSystemMetrics(SM_CXVSCROLL);
SendMessage(cb.Handle, CB_SETDROPPEDWIDTH, iWidthFull, 0);
Visible:= true;
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), 80, ButtonWidth, ButtonHeight);
end;
with TButton.Create(frm) do
begin
Parent:= frm;
Caption:= 'Zru<72>it';
ModalResult:= mrCancel;
Cancel:= True;
SetBounds(MulDiv(100, DialogUnits.X, 4), 80, ButtonWidth, ButtonHeight);
end;
if (ShowModal=mrOK) then
begin
result:= true;
cbText:= cb.Text;
end;
finally
frm.Free;
end;
end;
function FormComboBoxMemo (const Title, Desc, Desc2: string; const inStr: TStringList; var cbText, memoText: string; setFirst: boolean): boolean;
const HORIZ_PADDING = 4;
CB_SETDROPPEDWIDTH = 352;
var frm: TForm;
lbl1: TLabel;
lbl2: TLabel;
cb: TComboBox;
m: TMemo;
btnOK, btnCancel: TButton;
DialogUnits: TPoint;
ButtonWidth, ButtonHeight, rNum: Integer;
idx, iWidth, iWidthFull: integer;
bmp: TBitmap;
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);
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.DropDownCount<cb.Items.Count) then
iWidthFull:= iWidthFull + GetSystemMetrics(SM_CXVSCROLL);
SendMessage(cb.Handle, CB_SETDROPPEDWIDTH, iWidthFull, 0);
Visible:= true;
end;
lbl2:= TLabel.Create(frm);
with lbl2 do
begin
Parent:= frm;
Caption:= Desc2;
Left:= MulDiv(8, DialogUnits.X, 4);
Top:= lbl1.Top + lbl1.Height + 10;
Constraints.MaxWidth:= MulDiv(164, DialogUnits.X, 4);
WordWrap:= True;
end;
bmp:= TBitmap.Create;
m:= TMemo.Create(frm);
with m do
begin
Parent:= frm;
Top:= lbl2.Top + lbl2.Height + 6;
Left:= lbl2.Left;
Width:= (frm.Width div 100)*95;
bmp.Canvas.Font.Assign(m.Font);
Height:= 5 * bmp.Canvas.TextHeight('Wq');
end;
FreeAndNil(bmp);
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
btnOK:= TButton.Create(frm);
with btnOK do
begin
Parent:= frm;
Caption:= 'OK';
ModalResult:= mrOK;
Default:= true;
SetBounds(MulDiv(20, DialogUnits.X, 4), m.Top + m.Height + 10, ButtonWidth, ButtonHeight);
end;
btnCancel:= TButton.Create(frm);
with btnCancel do
begin
Parent:= frm;
Caption:= 'Zru<72>it';
ModalResult:= mrCancel;
Cancel:= True;
SetBounds(MulDiv(100, DialogUnits.X, 4), m.Top + m.Height + 10, ButtonWidth, ButtonHeight);
end;
if (setFirst) then
cb.ItemIndex:= 0;
Height:= btnOK.Top + btnOK.Width; // frm
if (ShowModal=mrOK) then
begin
result:= true;
cbText:= cb.Text;
memoText:= Trim(m.Lines.Text);
end;
finally
frm.Free;
end;
end;
function FormInfo (const Title, Popis: string): boolean;
var frm: TForm;
btnOK: TButton;
DialogUnits: TPoint;
ButtonWidth, ButtonHeight: Integer;
l: TLabel;
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:= 500;
ClientHeight:= 250;
Position:= poOwnerFormCenter;
l:= TLabel.Create(frm);
with l do
begin
l.Left:= 3;
l.Width:= frm.Width - 6;
l.Caption:= popis;
end;
ButtonWidth := MulDiv(60, DialogUnits.X, 4);
ButtonHeight := MulDiv(25, DialogUnits.Y, 8);
btnOK:= TButton.Create(frm);
with btnOK do
begin
Caption:= 'OK';
ModalResult:= mrOK;
Default:= true;
Left:= frm.Width - ButtonWidth - 20;
Top:= frm.Height - (ButtonHeight*2);
Width:= ButtonWidth;
Height:= ButtonHeight;
Visible:= True;
// SetBounds(MulDiv(20, DialogUnits.X, 4), 100, ButtonWidth, ButtonHeight);
end;
if (ShowModal=mrOK) then
result:= true;
finally
frm.Free;
end;
end;
function FormMemo2 (const Title: string; var mText: string; const ReadOnly: boolean; fontSize: integer): boolean;
var frm: TForm;
m: TMemo;
btnOK, btnCancel: TButton;
DialogUnits: TPoint;
ButtonWidth, ButtonHeight: Integer;
begin
if (fontSize=0) then
fontSize:= 10;
result:= false;
frm:= TForm.Create(nil);
with frm do
try
Canvas.Font:= Font;
DialogUnits:= GetAveCharSize(Canvas);
BorderStyle:= bsDialog;
Caption:= Title;
Font.Size:= 10;
ClientWidth:= 500;
ClientHeight:= 250;
Position:= poScreenCenter;
m:= TMemo.Create(frm);
with m do
begin
Parent:= frm;
Color:= $00F0F0F0;
Left:= 5;
Top:= 5;
Height:= frm.Height - 30;
Width:= frm.Width - 20;
WordWrap:= True;
Text:= mText;
Font.Size:= fontSize;
end;
m.ReadOnly:= ReadOnly;
if not(readOnly) then
begin
ButtonWidth := MulDiv(60, DialogUnits.X, 4);
ButtonHeight := MulDiv(25, DialogUnits.Y, 8);
btnOK:= TButton.Create(frm);
btnCancel:= TButton.Create(frm);
with btnCancel do
begin
Caption:= 'Zru<72>it';
ModalResult:= mrCancel;
Cancel:= True;
Left:= frm.Width - ButtonWidth - 20;
Top:= frm.Height - (ButtonHeight*2);
Width:= ButtonWidth;
Height:= ButtonHeight;
Visible:= True;
// SetBounds(MulDiv(100, DialogUnits.X, 4), 100, ButtonWidth, ButtonHeight);
end;
with btnOK do
begin
Caption:= 'OK';
ModalResult:= mrOK;
Default:= true;
Left:= btnCancel.Left - ButtonWidth - 50;
Top:= frm.Height - (ButtonHeight*2);
Width:= ButtonWidth;
Height:= ButtonHeight;
Visible:= True;
// SetBounds(MulDiv(20, DialogUnits.X, 4), 100, ButtonWidth, ButtonHeight);
end;
end;
if (ShowModal=mrOK) then
begin
result:= true;
mText:= Trim(m.Text);
end;
finally
frm.Free;
end;
end;
function FormCislo (const Title, Desc: string; var NumOut: Extended): boolean;
var frm: TForm;
lbl1: TLabel;
edtNum: TEdit;
btnOK,btnCancel: TButton;
DialogUnits: TPoint;
ButtonWidth, ButtonHeight, rNum: Integer;
begin
result:= false;
NumOut:= 0;
frm:= TForm.Create(nil);
with frm do
try
Canvas.Font:= Font;
DialogUnits:= GetAveCharSize(Canvas);
BorderStyle:= bsDialog;
Caption:= Title;
Font.Size:= 10;
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;
edtNum:= TEdit.Create(frm);
with edtNum do
begin
Parent:= frm;
Alignment:= taCenter;
MaxLength:= 16;
Top:= lbl1.Top;
Left:= lbl1.Left + lbl1.Width + 10;
Width:= 90;
Visible:= true;
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), 80, ButtonWidth, ButtonHeight);
end;
with TButton.Create(frm) do
begin
Parent:= frm;
Caption:= 'Zru<72>it';
ModalResult:= mrCancel;
Cancel:= True;
SetBounds(MulDiv(100, DialogUnits.X, 4), 80, ButtonWidth, ButtonHeight);
end;
if (ShowModal=mrOK) then
begin
result:= true;
edtNum.Text:= Trim(edtNum.Text);
edtNum.Text:= StringReplace(edtNum.Text,' ','',[rfReplaceAll]);
edtNum.Text:= StringReplace(edtNum.Text,'.',',',[rfReplaceAll]);
if (LeftStr(edtNum.Text,1)=',') then
edtNum.Text:= '0' + edtNum.Text;
if not(TryStrToFloat(edtNum.Text,NumOut)) then
NumOut:= 0;
end;
finally
frm.Free;
end;
end;
function FormDatum (const Title, Desc: string; var datOut: TDatetime): boolean;
var frm: TForm;
lbl1: TLabel;
dt: TDateTimePicker;
// 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:= Desc;
Left:= MulDiv(8, DialogUnits.X, 4);
Top:= MulDiv(8, DialogUnits.X, 4);
Constraints.MaxWidth:= MulDiv(164, DialogUnits.X, 4);
WordWrap:= True;
end;
dt:= TDateTimePicker.Create(frm);
with dt do
begin
Parent:= frm;
Kind:= dtkDate;
DateMode:= dmComboBox;
Date:= Now;
Top:= lbl1.Top;
Left:= lbl1.Left + lbl1.Width + 10;
Width:= 120;
Visible:= true;
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<72>it';
ModalResult:= mrCancel;
Cancel:= True;
SetBounds(MulDiv(100, DialogUnits.X, 4), 100, ButtonWidth, ButtonHeight);
end;
if ShowModal=mrOK then
begin
result:= true;
datOut:= dt.Date;
end;
finally
frm.Free;
end;
end;
function FormMemo (const Title, Desc: string; var memText: string): boolean;
var frm: TForm;
lbl1: TLabel;
m: TMemo;
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;
ClientWidth:= MulDiv(180, DialogUnits.X, 4);
ClientHeight:= 150;
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) - 5;
Constraints.MaxWidth:= MulDiv(164, DialogUnits.X, 4);
WordWrap:= True;
end;
m:= TMemo.Create(frm);
with m do
begin
Parent:= frm;
Lines.Text:= '';
Top:= lbl1.Top;
Left:= lbl1.Left + lbl1.Width + 10;
Width:= 210;
Height:= 92;
Visible:= true;
Text:= memText;
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), 120, ButtonWidth, ButtonHeight);
end;
with TButton.Create(frm) do
begin
Parent:= frm;
Caption:= 'Zru<72>it';
ModalResult:= mrCancel;
Cancel:= True;
SetBounds(MulDiv(100, DialogUnits.X, 4), 120, ButtonWidth, ButtonHeight);
end;
if (ShowModal=mrOK) then
begin
result:= true;
memText:= Trim(m.Lines.Text);
// if (mem='') then
// result:= false;
end;
finally
frm.Free;
end;
end;
function IDckaTabulky (const tbl: TFDMemTable; pole: string): string;
var i: integer;
begin
result:= '';
if tbl.RecordCount>0 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<6A>te sou<6F>adnice obsahu
NajdiContentBounds (ASourceBitmap, Left, Top, Right, Bottom, BackgroundColor);
// Pokud je n<>jak<61> obsah nalezen...
if (Left <> -1) and (Top <> -1) and (Right <> -1) and (Bottom <> -1) then
begin
// Vypo<70><6F>tejte rozm<7A>ry o<>ezan<61>ho obr<62>zku
ACroppedBitmap := TBitmap.Create;
ACroppedBitmap.Width := (Right - Left) + 1;
ACroppedBitmap.Height := (Bottom - Top) + 1;
// Definujte zdrojov<6F> a c<>lov<6F> obd<62>ln<6C>k
SourceRect := Rect(Left, Top, Right + 1, Bottom + 1); // +1 proto<74>e TRect.Bottom a .Right jsou exkluzivn<76>
DestRect := Rect(0, 0, ACroppedBitmap.Width, ACroppedBitmap.Height);
// Zkop<6F>rujte data
ACroppedBitmap.Canvas.CopyRect(DestRect, ASourceBitmap.Canvas, SourceRect);
end
else
begin
// <20><>dn<64> obsah nebyl nalezen, vra<72>te nil nebo pr<70>zdn<64> 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<65> horn<72>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<65> doln<6C>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<65> lev<65>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<65> prav<61>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.
Reference in New Issue View Git Blame Copy Permalink