1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619 |
- //[START OF KOL.pas]
- {****************************************************************
- d d
- KKKKK KKKKK OOOOOOOOO LLLLL d d
- KKKKK KKKKK OOOOOOOOOOOOO LLLLL d d
- KKKKK KKKKK OOOOO OOOOO LLLLL aaaa d d
- KKKKK KKKKK OOOOO OOOOO LLLLL a d d
- KKKKKKKKKK OOOOO OOOOO LLLLL a d d
- KKKKK KKKKK OOOOO OOOOO LLLLL aaaaa dddddd dddddd
- KKKKK KKKKK OOOOO OOOOO LLLLL a a d d d d
- KKKKK KKKKK OOOOOOOOOOOOO LLLLLLLLLLLLL a a d d d d
- KKKKK KKKKK OOOOOOOOO LLLLLLLLLLLLL aaaaa aa dddddd dddddd
-
- Key Objects Library (C) 2000 by Kladov Vladimir.
-
- //[VERSION]
- ****************************************************************
- * VERSION 2.75
- ****************************************************************
- //[END OF VERSION]
-
- The only reason why this part of KOL separated into another unit is that
- Delphi has a restriction to DCU size exceeding which it is failed to debug
- it normally and in attempt to execute code step by step an internal error
- is occur which stops Delphi from working at all.
-
- Version indicated above is a version of KOL, having place when KOLadd.pas was
- modified last time, this is not a version of KOLadd itself.
- }
-
- {$ifdef FPC} {$mode delphi} {$endif FPC}
- unit KOLadd;
-
- {*
- Define symbol TREE_NONAME to disallow using Name in TTree object.
- Define symbol TREE_WIDE to use WideString for Name in TTree object.
- }
- {$IFDEF EXTERNAL_DEFINES}
- {$INCLUDE EXTERNAL_DEFINES.INC}
- {$ENDIF EXTERNAL_DEFINES}
-
-
- interface
-
- {$I KOLDEF.INC}
-
- uses Windows, Messages, KOL {$IFDEF USE_GRUSH}, ToGrush {$ENDIF};
-
- {------------------------------------------------------------------------------)
- | |
- | T L i s t E x |
- | |
- (------------------------------------------------------------------------------}
- type
-
- //[TListEx DEFINITION]
- {++}(*TListEx = class;*){--}
- PListEx = {-}^{+}TListEx;
- TListEx = object( TObj )
- {* Extended list, with Objects[ ] property. Created calling NewListEx function. }
- protected
- fList: PList;
- fObjects: PList;
- function GetEx(Idx: Integer): Pointer;
- procedure PutEx(Idx: Integer; const Value: Pointer);
- function GetCount: Integer;
- function GetAddBy: Integer;
- procedure Set_AddBy(const Value: Integer);
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- property AddBy: Integer read GetAddBy write Set_AddBy;
- {* }
- property Items[ Idx: Integer ]: Pointer read GetEx write PutEx;
- {* }
- property Count: Integer read GetCount;
- {* }
- procedure Clear;
- {* }
- procedure Add( Value: Pointer );
- {* }
- procedure AddObj( Value, Obj: Pointer );
- {* }
- procedure Insert( Idx: Integer; Value: Pointer );
- {* }
- procedure InsertObj( Idx: Integer; Value, Obj: Pointer );
- {* }
- procedure Delete( Idx: Integer );
- {* }
- procedure DeleteRange( Idx, Len: Integer );
- {* }
- function IndexOf( Value: Pointer ): Integer;
- {* }
- function IndexOfObj( Obj: Pointer ): Integer;
- {* }
- procedure Swap( Idx1, Idx2: Integer );
- {* }
- procedure MoveItem( OldIdx, NewIdx: Integer );
- {* }
- property ItemsList: PList read fList;
- {* }
- property ObjList: PList read fObjects;
- {* }
- function Last: Pointer;
- {* }
- function LastObj: Pointer;
- {* }
- end;
- //[END OF TListEx DEFINITION]
-
- //[NewListEx DECLARATION]
- function NewListEx: PListEx;
- {* Creates extended list. }
-
- {------------------------------------------------------------------------------)
- | |
- | T B i t s |
- | |
- (------------------------------------------------------------------------------}
- type
- //[TBits DEFINITION]
- {++}(*TBits = class;*){--}
- PBits = {-}^{+}TBits;
- TBits = object( TObj )
- {* Variable-length bits array object. Created using function NewBits. See also
- |<a href="kol_pas.htm#Small bit arrays (max 32 bits in array)">
- Small bit arrays (max 32 bits in array)
- |</a>. }
- protected
- fList: PList;
- fCount: Integer;
- function GetBit(Idx: Integer): Boolean;
- procedure SetBit(Idx: Integer; const Value: Boolean);
- function GetCapacity: Integer;
- function GetSize: Integer;
- procedure SetCapacity(const Value: Integer);
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- property Bits[ Idx: Integer ]: Boolean read GetBit write SetBit;
- {* }
- property Size: Integer read GetSize;
- {* Size in bytes of the array. To get know number of bits, use property Count. }
- property Count: Integer read fCount;
- {* Number of bits an the array. }
- property Capacity: Integer read GetCapacity write SetCapacity;
- {* Number of bytes allocated. Can be set before assigning bit values
- to improve performance (minimizing amount of memory allocation
- operations). }
- function Copy( From, BitsCount: Integer ): PBits;
- {* Use this property to get a sub-range of bits starting from given bit
- and of BitsCount bits count. }
- function IndexOf( Value: Boolean ): Integer;
- {* Returns index of first bit with given value (True or False). }
- function OpenBit: Integer;
- {* Returns index of the first bit not set to true. }
- procedure Clear;
- {* Clears bits array. Count, Size and Capacity become 0. }
- function LoadFromStream( strm: PStream ): Integer;
- {* Loads bits from the stream. Data should be stored in the stream
- earlier using SaveToStream method. While loading, previous bits
- data are discarded and replaced with new one totally. In part,
- Count of bits also is changed. Count of bytes read from the stream
- while loading data is returned. }
- function SaveToStream( strm: PStream ): Integer;
- {* Saves entire array of bits to the stream. First, Count of bits
- in the array is saved, then all bytes containing bits data. }
- function Range( Idx, N: Integer ): PBits;
- {* Creates and returns new TBits object instance containing N bits
- starting from index Idx. If you call this method, you are responsible
- for destroying returned object when it become not neccessary. }
- procedure AssignBits( ToIdx: Integer; FromBits: PBits; FromIdx, N: Integer );
- {* Assigns bits from another bits array object. N bits are assigned
- starting at index ToIdx. }
- procedure InstallBits( FromIdx, N: Integer; Value: Boolean );
- {* Sets new Value for all bits in range [ FromIdx, FromIdx+Count-1 ]. }
- end;
- //[END OF TBits DEFINITION]
-
- //[NewBits DECLARATION]
- function NewBits: PBits;
- {* Creates variable-length bits array object. }
-
- {------------------------------------------------------------------------------)
- | |
- | T F a s t S t r L i s t |
- | |
- (------------------------------------------------------------------------------}
- type
- PFastStrListEx = ^TFastStrListEx;
- TFastStrListEx = object( TObj )
- private
- function GetItemLen(Idx: Integer): Integer;
- function GetObject(Idx: Integer): DWORD;
- procedure SetObject(Idx: Integer; const Value: DWORD);
- function GetValues(AName: PChar): PChar;
- protected
- procedure Init; virtual;
- protected
- fList: PList;
- fCount: Integer;
- fCaseSensitiveSort: Boolean;
- fTextBuf: PChar;
- fTextSiz: DWORD;
- fUsedSiz: DWORD;
- protected
- procedure ProvideSpace( AddSize: DWORD );
- function Get(Idx: integer): string;
- function GetTextStr: string;
- procedure Put(Idx: integer; const Value: string);
- procedure SetTextStr(const Value: string);
- function GetPChars( Idx: Integer ): PChar;
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- public
- function AddAnsi( const S: String ): Integer;
- {* Adds Ansi String to a list. }
- function AddAnsiObject( const S: String; Obj: DWORD ): Integer;
- {* Adds Ansi String and correspondent object to a list. }
- function Add(S: PChar): integer;
- {* Adds a string to list. }
- function AddLen(S: PChar; Len: Integer): integer;
- {* Adds a string to list. The string can contain #0 characters. }
- public
- FastClear: Boolean;
- {* }
- procedure Clear;
- {* Makes string list empty. }
- procedure Delete(Idx: integer);
- {* Deletes string with given index (it *must* exist). }
- function IndexOf(const S: string): integer;
- {* Returns index of first string, equal to given one. }
- function IndexOf_NoCase(const S: string): integer;
- {* Returns index of first string, equal to given one (while comparing it
- without case sensitivity). }
- function IndexOfStrL_NoCase( Str: PChar; L: Integer ): integer;
- {* Returns index of first string, equal to given one (while comparing it
- without case sensitivity). }
- function Find(const S: String; var Index: Integer): Boolean;
- {* Returns Index of the first string, equal or greater to given pattern, but
- works only for sorted TFastStrListEx object. Returns TRUE if exact string found,
- otherwise nearest (greater then a pattern) string index is returned,
- and the result is FALSE. }
- procedure InsertAnsi(Idx: integer; const S: String);
- {* Inserts ANSI string before one with given index. }
- procedure InsertAnsiObject(Idx: integer; const S: String; Obj: DWORD);
- {* Inserts ANSI string before one with given index. }
- procedure Insert(Idx: integer; S: PChar);
- {* Inserts string before one with given index. }
- procedure InsertLen( Idx: Integer; S: PChar; Len: Integer );
- {* Inserts string from given PChar. It can contain #0 characters. }
- function LoadFromFile(const FileName: string): Boolean;
- {* Loads string list from a file. (If file does not exist, nothing
- happens). Very fast even for huge text files. }
- procedure LoadFromStream(Stream: PStream; Append2List: boolean);
- {* Loads string list from a stream (from current position to the end of
- a stream). Very fast even for huge text. }
- procedure MergeFromFile(const FileName: string);
- {* Merges string list with strings in a file. Fast. }
- procedure Move(CurIndex, NewIndex: integer);
- {* Moves string to another location. }
- procedure SetText(const S: string; Append2List: boolean);
- {* Allows to set strings of string list from given string (in which
- strings are separated by $0D,$0A or $0D characters). Text can
- contain #0 characters. Works very fast. This method is used in
- all others, working with text arrays (LoadFromFile, MergeFromFile,
- Assign, AddStrings). }
- function SaveToFile(const FileName: string): Boolean;
- {* Stores string list to a file. }
- procedure SaveToStream(Stream: PStream);
- {* Saves string list to a stream (from current position). }
- function AppendToFile(const FileName: string): Boolean;
- {* Appends strings of string list to the end of a file. }
- property Count: integer read fCount;
- {* Number of strings in a string list. }
- property Items[Idx: integer]: string read Get write Put; default;
- {* Strings array items. If item does not exist, empty string is returned.
- But for assign to property, string with given index *must* exist. }
- property ItemPtrs[ Idx: Integer ]: PChar read GetPChars;
- {* Fast access to item strings as PChars. }
- property ItemLen[ Idx: Integer ]: Integer read GetItemLen;
- {* Length of string item. }
- function Last: String;
- {* Last item (or '', if string list is empty). }
- property Text: string read GetTextStr write SetTextStr;
- {* Content of string list as a single string (where strings are separated
- by characters $0D,$0A). }
- procedure Swap( Idx1, Idx2 : Integer );
- {* Swaps to strings with given indeces. }
- procedure Sort( CaseSensitive: Boolean );
- {* Call it to sort string list. }
- public
- function AddObject( S: PChar; Obj: DWORD ): Integer;
- {* Adds string S (null-terminated) with associated object Obj. }
- function AddObjectLen( S: PChar; Len: Integer; Obj: DWORD ): Integer;
- {* Adds string S of length Len with associated object Obj. }
- procedure InsertObject( Idx: Integer; S: PChar; Obj: DWORD );
- {* Inserts string S (null-terminated) at position Idx in the list,
- associating it with object Obj. }
- procedure InsertObjectLen( Idx: Integer; S: PChar; Len: Integer; Obj: DWORD );
- {* Inserts string S of length Len at position Idx in the list,
- associating it with object Obj. }
- property Objects[ Idx: Integer ]: DWORD read GetObject write SetObject;
- {* Access to objects associated with strings in the list. }
- public
- procedure Append( S: PChar );
- {* Appends S (null-terminated) to the last string in FastStrListEx object, very fast. }
- procedure AppendLen( S: PChar; Len: Integer );
- {* Appends S of length Len to the last string in FastStrListEx object, very fast. }
- procedure AppendInt2Hex( N: DWORD; MinDigits: Integer );
- {* Converts N to hexadecimal and appends resulting string to the last
- string, very fast. }
- public
- property Values[ Name: PChar ]: PChar read GetValues;
- {* Returns a value correspondent to the Name an ini-file-like string list
- (having Name1=Value1 Name2=Value2 etc. in each string). }
- function IndexOfName( AName: PChar ): Integer;
- {* Searches string starting from 'AName=' in string list like ini-file. }
- end;
-
- function NewFastStrListEx: PFastStrListEx;
- {* Creates FastStrListEx object. }
-
- var Upper: array[ Char ] of Char;
- {* An table to convert char to uppercase very fast. First call InitUpper. }
-
- Upper_Initialized: Boolean;
- procedure InitUpper;
- {* Call this fuction ones to fill Upper[ ] table before using it. }
-
- //[CABINET FILES OBJECT]
- type
- {++}(*TCabFile = class;*){--}
- PCABFile = {-}^{+}TCABFile;
-
- TOnNextCAB = function( Sender: PCABFile ): KOLString of object;
- TOnCABFile = function( Sender: PCABFile; var FileName: KOLString ): Boolean of object;
-
- { ----------------------------------------------------------------------
-
- TCabFile - windows cabinet files
-
- ----------------------------------------------------------------------- }
- //[TCabFile DEFINITION]
- TCABFile = object( TObj )
- {* An object to simplify extracting files from a cabinet (.CAB) files.
- The only what need to use this object, setupapi.dll. It is provided
- with all latest versions of Windows. }
- protected
- FPaths: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
- FNames: {$IFDEF UNICODE_CTRLS} PWStrList {$ELSE} PStrList {$ENDIF};
- FOnNextCAB: TOnNextCAB;
- FOnFile: TOnCABFile;
- FTargetPath: KOLString;
- FSetupapi: THandle;
- function GetNames(Idx: Integer): KOLString;
- function GetCount: Integer;
- function GetPaths(Idx: Integer): KOLString;
- function GetTargetPath: KOLString;
- protected
- FGettingNames: Boolean;
- FCurCAB: Integer;
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- property Paths[ Idx: Integer ]: KOLString read GetPaths;
- {* A list of CAB-files. It is stored, when constructing function
- OpenCABFile called. }
- property Names[ Idx: Integer ]: KOLString read GetNames;
- {* A list of file names, stored in a sequence of CAB files. To get know,
- how many files are there, check Count property. }
- property Count: Integer read GetCount;
- {* Number of files stored in a sequence of CAB files. }
- function Execute: Boolean;
- {* Call this method to extract or enumerate files in CAB. For every
- file, found during executing, event OnFile is alled (if assigned).
- If the event handler (if any) does not provide full target path for
- a file to extract to, property TargetPath is applyed (also if it
- is assigned), or file is extracted to the default directory (usually
- the same directory there CAB file is located, or current directory
- - by a decision of the system).
- |<br>
- If a sequence of CAB files is used, and not all names for CAB files
- are provided (absent or represented by a string '?' ), an event
- OnNextCAB is called to obtain the name of the next CAB file.}
- property CurCAB: Integer read FCurCAB;
- {* Index of current CAB file in a sequence of CAB files. When OnNextCAB
- event is called (if any), CurCAB property is already set to the
- index of path, what should be provided. }
- property OnNextCAB: TOnNextCAB read FOnNextCAB write FOnNextCAB;
- {* This event is called, when a series of CAB files is needed and not
- all CAB file names are provided (absent or represented by '?' string).
- If this event is not assigned, the user is prompted to browse file. }
- property OnFile: TOnCABFile read FOnFile write FOnFile;
- {* This event is called for every file found during Execute method.
- In an event handler (if any assigned), it is possible to return
- False to skip file, or to provide another full target path for
- file to extract it to, then default. If the event is not assigned,
- all files are extracted either to default directory, or to the
- directory TargetPath, if it is provided. }
- property TargetPath: KOLString read GetTargetPath write FTargetPath;
- {* Optional target directory to place there extracted files. }
- end;
- //[END OF TCABFile DEFINITION]
-
- //[OpenCABFile DECLARATION]
- function OpenCABFile( const APaths: array of String ): PCABFile;
- {* This function creates TCABFile object, passing a sequence of CAB file names
- (fully qualified). It is possible not to provide all names here, or pass '?'
- string in place of some of those. For such files, either an event OnNextCAB
- will be called, or (and) user will be prompted to browse file during
- executing (i.e. Extracting). }
-
- //[DIRCHANGE]
- type
- {++}(*TDirChange = class;*){--}
- PDirChange = {-}^{+}TDirChange;
- {* }
-
- TOnDirChange = procedure (Sender: PDirChange; const Path: KOLString) of object;
- {* Event type to define OnChange event for folder monitoring objects. }
-
- TFileChangeFilters = (fncFileName, fncDirName, fncAttributes, fncSize,
- fncLastWrite, fncLastAccess, fncCreation, fncSecurity);
- {* Possible change monitor filters. }
- TFileChangeFilter = set of TFileChangeFilters;
- {* Set of filters to pass to a constructor of TDirChange object. }
-
- { ----------------------------------------------------------------------
-
- TDirChange object
-
- ----------------------------------------------------------------------- }
- //[TDirChange DEFINITION]
- TDirChange = object(TObj)
- {* Object type to monitor changes in certain folder. }
- protected
- FOnChange: TOnDirChange;
- FHandle, FinEvent: THandle;
- FPath: KOLString;
- FMonitor: PThread;
- function Execute( Sender: PThread ): Integer;
- procedure Changed;
- protected
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {*}
- public
- property Handle: THandle read FHandle;
- {* Handle of file change notification object. *}
- property Path: KOLString read FPath; //write SetPath;
- {* Path to monitored folder (to a root, if tree of folders
- is under monitoring). }
- property OnChange: TOnDirChange read FOnChange write FOnChange;
- end;
- //[END OF TDirChange DEFINITION]
-
- //[NewDirChangeNotifier DECLARATION]
- function NewDirChangeNotifier( const Path: KOLString; Filter: TFileChangeFilter;
- WatchSubtree: Boolean; ChangeProc: TOnDirChange ): PDirChange;
- {* Creates notification object TDirChange. If something wrong (e.g.,
- passed directory does not exist), nil is returned as a result. When change
- is notified, ChangeProc is called always in main thread context.
- (Please note, that ChangeProc can not be nil).
- If empty filter is passed, default filter is used:
- [fncFileName..fncLastWrite]. }
-
- {$ifdef win32}
- //[METAFILES]
-
- type
- {++}(*TMetafile = class;*){--}
- PMetafile = {-}^{+}TMetafile;
- { ----------------------------------------------------------------------
-
- TMetafile - Windows metafile and Enchanced Metafile image
-
- ----------------------------------------------------------------------- }
- //[TMetafile DEFINITION]
- TMetafile = object( TObj )
- {* Object type to incapsulate metafile image. }
- protected
- function GetHeight: Integer;
- function GetWidth: Integer;
- procedure SetHandle(const Value: THandle);
- protected
- fHandle: THandle;
- fHeader: PEnhMetaHeader;
- procedure RetrieveHeader;
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- procedure Clear;
- {* }
- function Empty: Boolean;
- {* Returns TRUE if empty}
- property Handle: THandle read fHandle write SetHandle;
- {* Returns handle of enchanced metafile. }
- function LoadFromStream( Strm: PStream ): Boolean;
- {* Loads emf or wmf file format from stream. }
- function LoadFromFile( const Filename: String ): Boolean;
- {* Loads emf or wmf from stream. }
- procedure Draw( DC: HDC; X, Y: Integer );
- {* Draws enchanced metafile on DC. }
- procedure StretchDraw( DC: HDC; const R: TRect );
- {* Draws enchanced metafile stretched. }
- property Width: Integer read GetWidth;
- {* Native width of the metafile. }
- property Height: Integer read GetHeight;
- {* Native height of the metafile. }
- end;
- //[END OF TMetafile DEFINITION]
-
- //[NewMetafile DECLARATION]
- function NewMetafile: PMetafile;
- {* Creates metafile object. }
-
- //[Metafile CONSTANTS, STRUCTURES, ETC.]
- const
- WMFKey = Integer($9AC6CDD7);
- WMFWord = $CDD7;
- type
- TMetafileHeader = packed record
- Key: Longint;
- Handle: SmallInt;
- Box: TSmallRect;
- Inch: Word;
- Reserved: Longint;
- CheckSum: Word;
- end;
-
- function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
-
- {++}(*
- function SetEnhMetaFileBits(p1: UINT; p2: PChar): HENHMETAFILE; stdcall;
- function PlayEnhMetaFile(DC: HDC; p2: HENHMETAFILE; const p3: TRect): BOOL; stdcall;
- *){--}
- {$endif win32}
-
- // NewActionList, TAction - by Yury Sidorov
- //[ACTIONS OBJECT]
- { ----------------------------------------------------------------------
-
- TAction and TActionList
-
- ----------------------------------------------------------------------- }
- type
- PControlRec = ^TControlRec;
- TOnUpdateCtrlEvent = procedure(Sender: PControlRec) of object;
-
- TCtrlKind = (ckControl, ckMenu, ckToolbar);
- TControlRec = record
- Ctrl: PObj;
- CtrlKind: TCtrlKind;
- ItemID: integer;
- UpdateProc: TOnUpdateCtrlEvent;
- end;
-
- TUpdateProperty = (upCaption, upHint, upChecked, upEnabled, upVisible, upHelpContext, upAccelerator);
- TUpdateProperties = set of TUpdateProperty;
-
- {++}(* TAction = class;*){--}
- PAction = {-}^{+}TAction;
-
- {++}(* TActionList = class;*){--}
- PActionList = {-}^{+}TActionList;
-
- //[TAction DEFINITION]
- TAction = {-} object( TObj ) {+}{++}(*class*){--}
- {*! Use action objects, in conjunction with action lists, to centralize the response
- to user commands (actions).
- Use AddControl, AddMenuItem, AddToolbarButton methods to link controls to an action.
- See also TActionList.
- }
- protected
- FControls: PList;
- FCaption: KOLString;
- FChecked: boolean;
- FVisible: boolean;
- FEnabled: boolean;
- FHelpContext: integer;
- FHint: KOLString;
- FOnExecute: TOnEvent;
- FAccelerator: TMenuAccelerator;
- {$ifndef wince}
- FShortCut: KOLString;
- {$endif wince}
- FUpdateMask: TUpdateProperties;
- procedure DoOnMenuItem(Sender: PMenu; Item: Integer);
- procedure DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);
- procedure DoOnControlClick(Sender: PObj);
-
- procedure SetCaption(const Value: KOLString);
- procedure SetChecked(const Value: boolean);
- procedure SetEnabled(const Value: boolean);
- procedure SetHelpContext(const Value: integer);
- procedure SetHint(const Value: KOLString);
- procedure SetVisible(const Value: boolean);
- procedure SetAccelerator(const Value: TMenuAccelerator);
- procedure UpdateControls;
-
- procedure LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);
- procedure SetOnExecute(const Value: TOnEvent);
-
- procedure UpdateCtrl(Sender: PControlRec);
- procedure UpdateMenu(Sender: PControlRec);
- procedure UpdateToolbar(Sender: PControlRec);
-
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- procedure LinkControl(Ctrl: PControl);
- {* Add a link to a TControl or descendant control. }
- procedure LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);
- {* Add a link to a menu item. }
- procedure LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);
- {* Add a link to a toolbar button. }
- procedure Execute;
- {* Executes a OnExecute event handler. }
- property Caption: KOLString read FCaption write SetCaption;
- {* Text caption. }
- property Hint: KOLString read FHint write SetHint;
- {* Hint (tooltip). Currently used for toolbar buttons only. }
- property Checked: boolean read FChecked write SetChecked;
- {* Checked state. }
- property Enabled: boolean read FEnabled write SetEnabled;
- {* Enabled state. }
- property Visible: boolean read FVisible write SetVisible;
- {* Visible state. }
- property HelpContext: integer read FHelpContext write SetHelpContext;
- {* Help context. }
- property Accelerator: TMenuAccelerator read FAccelerator write SetAccelerator;
- {* Accelerator for menu items. }
- property OnExecute: TOnEvent read FOnExecute write SetOnExecute;
- {* This event is executed when user clicks on a linked object or Execute method was called. }
- end;
- //[END OF TAction DEFINITION]
-
- //[TActionList DEFINITION]
- TActionList = {-} object( TObj ) {+}{++}(*class*){--}
- {*! TActionList maintains a list of actions used with components and controls,
- such as menu items and buttons.
- Action lists are used, in conjunction with actions, to centralize the response
- to user commands (actions).
- Write an OnUpdateActions handler to update actions state.
- Created using function NewActionList.
- See also TAction.
- }
- protected
- FOwner: PControl;
- FActions: PList;
- FOnUpdateActions: TOnEvent;
- function GetActions(Idx: integer): PAction;
- function GetCount: integer;
- protected
- procedure DoUpdateActions(Sender: PObj);
- public
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- function Add(const ACaption, AHint: KOLString; OnExecute: TOnEvent): PAction;
- {* Add a new action to the list. Returns pointer to action object. }
- procedure Delete(Idx: integer);
- {* Delete action by index from list. }
- procedure Clear;
- {* Clear all actions in the list. }
- property Actions[Idx: integer]: PAction read GetActions;
- {* Access to actions in the list. }
- property Count: integer read GetCount;
- {* Number of actions in the list.. }
- property OnUpdateActions: TOnEvent read FOnUpdateActions write FOnUpdateActions;
- {* Event handler to update actions state. This event is called each time when application
- goes in the idle state (no messages in the queue). }
- end;
- //[END OF TActionList DEFINITION]
-
- //[NewActionList DECLARATION]
- function NewActionList(AOwner: PControl): PActionList;
- {* Action list constructor. AOwner - owner form. }
-
- { -- tree (non-visual) -- }
-
- type
- //[TTree DEFINITION]
- {++}(*TTree = class;*){--}
- PTree = {-}^{+}TTree;
- TTree = object( TObj )
- {* Object to store tree-like data in memory (non-visual). }
- protected
- fParent: PTree;
- fChildren: PList;
- fPrev: PTree;
- fNext: PTree;
- {$IFDEF TREE_NONAME}
- {$ELSE}
- {$IFDEF TREE_WIDE}
- fNodeName: WideString;
- {$ELSE}
- fNodeName: String;
- {$ENDIF}
- {$ENDIF}
- fData: Pointer;
- function GetCount: Integer;
- function GetItems(Idx: Integer): PTree;
- procedure Unlink;
- function GetRoot: PTree;
- function GetLevel: Integer;
- function GetTotal: Integer;
- function GetIndexAmongSiblings: Integer;
- protected
- {$IFDEF USE_CONSTRUCTORS}
- constructor CreateTree( AParent: PTree; const AName: String );
- {* }
- {$ENDIF}
- {++}(*public*){--}
- destructor Destroy; {-}virtual;{+}{++}(*override;*){--}
- {* }
- {++}(*protected*){--}
- procedure Init; {-}virtual;{+}{++}(*override;*){--}
- public
- procedure Clear;
- {* Destoyes all child nodes. }
- {$IFDEF TREE_NONAME}
- {$ELSE}
- {$IFDEF TREE_WIDE}
- property Name: WideString read fNodeName write fNodeName;
- {$ELSE}
- property Name: String read fNodeName write fNodeName;
- {$ENDIF}
- {$ENDIF}
- {* Optional node name. }
- property Data: Pointer read fData write fData;
- {* Optional user-defined pointer. }
- property Count: Integer read GetCount;
- {* Number of child nodes of given node. }
- property Items[ Idx: Integer ]: PTree read GetItems;
- {* Child nodes list items. }
- procedure Add( Node: PTree );
- {* Adds another node as a child of given tree node. This operation
- as well as Insert can be used to move node together with its children
- to another location of the same tree or even from another tree.
- Anyway, added Node first correctly removed from old place (if it is
- defined for it). But for simplest task, such as filling of tree with
- nodes, code should looking as follows:
- ! Node := NewTree( nil, 'test of creating node without parent' );
- ! RootOfMyTree.Add( Node );
- Though, this code gives the same result as:
- ! Node := NewTree( RootOfMyTree, 'test of creatign node as a child' ); }
- procedure Insert( Before, Node: PTree );
- {* Inserts earlier created 'Node' just before given child node 'Before'
- as a child of given tree node. See also Add method. }
- property Parent: PTree read fParent;
- {* Returns parent node (or nil, if there is no parent). }
- property Index: Integer read GetIndexAmongSiblings;
- {* Returns an index of the node in a list of nodes of the same parent
- (or -1, if Parent is not defined). }
- property PrevSibling: PTree read fPrev;
- {* Returns previous node in a list of children of the Parent. Nil is
- returned, if given node is the first child of the Parent or has
- no Parent. }
- property NextSibling: PTree read fNext;
- {* Returns next node in a list of children of the Parent. Nil is returned,
- if given node is the last child of the Parent or has no Parent at all. }
- property Root: PTree read GetRoot;
- {* Returns root node (i.e. the last Parent, enumerating parents recursively). }
- property Level: Integer read GetLevel;
- {* Returns level of the node, i.e. integer value, equal to 0 for root
- of a tree, 1 for its children, etc. }
- property Total: Integer read GetTotal;
- {* Returns total number of children of the node and all its children
- counting its recursively (but node itself is not considered, i.e.
- Total for node without children is equal to 0). }
- procedure SortByName;
- {* Sorts children of the node in ascending order. Sorting is not
- recursive, i.e. only immediate children are sorted. }
- procedure SwapNodes( i1, i2: Integer );
- {* Swaps two child nodes. }
- function IsParentOfNode( Node: PTree ): Boolean;
- {* Returns true, if Node is the tree itself or is a parent of the given node
- on any level. }
- function IndexOf( Node: PTree ): Integer;
- {* Total index of the child node (on any level under this node). }
-
- end;
- //[END OF TTree DEFINITION]
-
- //[NewTree DECLARATION]
- {$IFDEF TREE_NONAME}
- function NewTree( AParent: PTree ): PTree;
- {* Nameless version (for case when TREE_NONAME symbol is defined).
- Constructs tree node, adding it to the end of children list of
- the AParent. If AParent is nil, new root tree node is created. }
- {$ELSE}
- {$IFDEF TREE_WIDE}
- function NewTree( AParent: PTree; const AName: WideString ): PTree;
- {* WideString version (for case when TREE_WIDE symbol is defined).
- Constructs tree node, adding it to the end of children list of
- the AParent. If AParent is nil, new root tree node is created. }
- {$ELSE}
- function NewTree( AParent: PTree; const AName: String ): PTree;
- {* Constructs tree node, adding it to the end of children list of
- the AParent. If AParent is nil, new root tree node is created. }
- {$ENDIF}
- {$ENDIF}
-
- {-------------------------------------------------------------------------------
- ADDITIONAL UTILITIES
- }
-
- function MapFileRead( const Filename: String; var hFile, hMap: THandle ): Pointer;
- {* Opens file for read only (with share deny none attribute) and maps its
- entire content using memory mapped files technique. The address of the
- first byte of file mapped into the application address space is returned.
- When mapping no more needed, it must be closed calling UnmapFile (see below).
- Maximum file size which can be mapped at a time is 1/4 Gigabytes. If file size
- exceeding this value only 1/4 Gigabytes starting from the beginning of the
- file is mapped therefore. }
-
- function MapFile( const Filename: String; var hFile, hMap: THandle ): Pointer;
- {* Opens file for read/write (in exlusive mode) and maps its
- entire content using memory mapped files technique. The address of the
- first byte of file mapped into the application address space is returned.
- When mapping no more needed, it must be closed calling UnmapFile (see below). }
-
- procedure UnmapFile( BasePtr: Pointer; hFile, hMap: THandle );
- {* Closes mapping opened via MapFile or MapFileRead call. }
-
- //------------------------ for MCK projects:
- type
- TKOLAction = PAction;
- TKOLActionList = PActionList;
-
- function ShowQuestion( const S: String; Answers: String ): Integer;
- {* Modal dialog like ShowMsgModal. It is based on KOL form, so it can
- be called also out of message loop, e.g. after finishing the
- application. Also, this function *must* be used in MDI applications
- in place of any dialog functions, based on MessageBox.
- |<br>
- The second parameter should be empty string or several possible
- answers separated by '/', e.g.: 'Yes/No/Cancel'. Result is
- a number answered, starting from 1. For example, if 'Cancel'
- was pressed, 3 will be returned.
- |<br>
- User can also press ESCAPE key, or close modal dialog. In such case
- -1 is returned. }
- function ShowQuestionEx( S: KOLString; Answers: KOLString; CallBack: TOnEvent ): Integer;
- {* Like ShowQuestion, but with CallBack function, called just before showing
- the dialog. }
- procedure ShowMsgModal( const S: String );
- {* This message function can be used out of a message loop (e.g., after
- finishing the application). It is always modal.
- Actually, a form with word-wrap label (decorated as borderless edit
- box with btnFace color) and with OK button is created and shown modal.
- When a dialog is called from outside message loop, caption 'Information'
- is always displayed.
- Dialog form is automatically resized vertically to fit message text
- (but until screen height is achieved) and shown always centered on
- screen. The width is fixed (400 pixels).
- |<br>
- Do not use this function outside the message loop for case, when the
- Applet variable is not used in an application. }
-
- implementation
-
- type
- PCrackList = ^TCrackList;
- TCrackList = object( TList )
- end;
-
- {------------------------------------------------------------------------------)
- | |
- | T L i s t E x |
- | |
- (------------------------------------------------------------------------------}
- { TListEx }
-
- //[function NewListEx]
- function NewListEx: PListEx;
- begin
- {-}
- new( Result, Create );
- {+}{++}(*Result := PListEx.Create;*){--}
- Result.fList := NewList;
- Result.fObjects := NewList;
- end;
- //[END NewListEx]
-
- //[procedure TListEx.Add]
- procedure TListEx.Add(Value: Pointer);
- begin
- AddObj( Value, nil );
- end;
-
- //[procedure TListEx.AddObj]
- procedure TListEx.AddObj(Value, Obj: Pointer);
- var C: Integer;
- begin
- C := Count;
- fList.Add( Value );
- fObjects.Insert( C, Obj );
- end;
-
- //[procedure TListEx.Clear]
- procedure TListEx.Clear;
- begin
- fList.Clear;
- fObjects.Clear;
- end;
-
- //[procedure TListEx.Delete]
- procedure TListEx.Delete(Idx: Integer);
- begin
- DeleteRange( Idx, 1 );
- end;
-
- //[procedure TListEx.DeleteRange]
- procedure TListEx.DeleteRange(Idx, Len: Integer);
- begin
- fList.DeleteRange( Idx, Len );
- fObjects.DeleteRange( Idx, Len );
- end;
-
- //[destructor TListEx.Destroy]
- destructor TListEx.Destroy;
- begin
- fList.Free;
- fObjects.Free;
- inherited;
- end;
-
- //[function TListEx.GetAddBy]
- function TListEx.GetAddBy: Integer;
- begin
- Result := fList.AddBy;
- end;
-
- //[function TListEx.GetCount]
- function TListEx.GetCount: Integer;
- begin
- Result := fList.Count;
- end;
-
- //[function TListEx.GetEx]
- function TListEx.GetEx(Idx: Integer): Pointer;
- begin
- Result := fList.Items[ Idx ];
- end;
-
- //[function TListEx.IndexOf]
- function TListEx.IndexOf(Value: Pointer): Integer;
- begin
- Result := fList.IndexOf( Value );
- end;
-
- //[function TListEx.IndexOfObj]
- function TListEx.IndexOfObj(Obj: Pointer): Integer;
- begin
- Result := fObjects.IndexOf( Obj );
- end;
-
- //[procedure TListEx.Insert]
- procedure TListEx.Insert(Idx: Integer; Value: Pointer);
- begin
- InsertObj( Idx, Value, nil );
- end;
-
- //[procedure TListEx.InsertObj]
- procedure TListEx.InsertObj(Idx: Integer; Value, Obj: Pointer);
- begin
- fList.Insert( Idx, Value );
- fObjects.Insert( Idx, Obj );
- end;
-
- //[function TListEx.Last]
- function TListEx.Last: Pointer;
- begin
- Result := fList.Last;
- end;
-
- //[function TListEx.LastObj]
- function TListEx.LastObj: Pointer;
- begin
- Result := fObjects.Last;
- end;
-
- //[procedure TListEx.MoveItem]
- procedure TListEx.MoveItem(OldIdx, NewIdx: Integer);
- begin
- fList.MoveItem( OldIdx, NewIdx );
- fObjects.MoveItem( OldIdx, NewIdx );
- end;
-
- //[procedure TListEx.PutEx]
- procedure TListEx.PutEx(Idx: Integer; const Value: Pointer);
- begin
- fList.Items[ Idx ] := Value;
- end;
-
- //[procedure TListEx.Set_AddBy]
- procedure TListEx.Set_AddBy(const Value: Integer);
- begin
- fList.AddBy := Value;
- fObjects.AddBy := Value;
- end;
-
- //[procedure TListEx.Swap]
- procedure TListEx.Swap(Idx1, Idx2: Integer);
- begin
- fList.Swap( Idx1, Idx2 );
- fObjects.Swap( Idx1, Idx2 );
- end;
-
- {------------------------------------------------------------------------------)
- | |
- | T B i t s |
- | |
- (------------------------------------------------------------------------------}
- { TBits }
-
- //[function NewBits]
- function NewBits: PBits;
- begin
- {-}
- new( Result, Create );
- {+}{++}(*Result := PBits.Create;*){--}
- Result.fList := NewList;
- //Result.fList.fAddBy := 1;
- end;
-
- //[procedure TBits.AssignBits]
- procedure TBits.AssignBits(ToIdx: Integer; FromBits: PBits; FromIdx,
- N: Integer);
- var i: Integer;
- NewCount: Integer;
- begin
- if FromIdx >= FromBits.Count then Exit;
- if FromIdx + N > FromBits.Count then
- N := FromBits.Count - FromIdx;
- Capacity := (ToIdx + N + 8) div 8;
- NewCount := Max( Count, ToIdx + N - 1 );
- fCount := Max( NewCount, fCount );
- PCrackList( fList ).fCount := (Capacity + 3) div 4;
- while ToIdx and $1F <> 0 do
- begin
- Bits[ ToIdx ] := FromBits.Bits[ FromIdx ];
- Inc( ToIdx );
- Inc( FromIdx );
- Dec( N );
- if N = 0 then Exit;
- end;
- Move( PByte( cardinal( PCrackList( FromBits.fList ).fItems ) + cardinal((FromIdx + 31) div 32) )^,
- PByte( cardinal( PCrackList( fList ).fItems ) + cardinal(ToIdx div 32) )^, (N + 31) div 32 );
- FromIdx := FromIdx and $1F;
- if FromIdx <> 0 then
- begin // shift data by (Idx and $1F) bits right
- for i := ToIdx div 32 to fList.Count-2 do
- fList.Items[ i ] := Pointer(
- (DWORD( fList.Items[ i ] ) shr FromIdx) or
- (DWORD( fList.Items[ i+1 ] ) shl (32 - FromIdx))
- );
- fList.Items[ fList.Count-1 ] := Pointer(
- DWORD( fList.Items[ fList.Count-1 ] ) shr FromIdx
- );
- end;
- end;
-
- //[function TBits.Copy]
- procedure TBits.Clear;
- begin
- fCount := 0;
- fList.Clear;
- end;
-
- function TBits.Copy(From, BitsCount: Integer): PBits;
- var Shift, N: Integer;
- FirstItemPtr: Pointer;
- begin
- Result := NewBits;
- if BitsCount = 0 then Exit;
- Result.Capacity := BitsCount + 32;
- Result.fCount := BitsCount;
- Move( PCrackList( fList ).fItems[ From shr 5 ],
- PCrackList( Result.fList ).fItems[ 0 ], (Count + 31) div 32 );
- Shift := From and $1F;
- if Shift <> 1 then
- begin
- N := (BitsCount + 31) div 32;
- FirstItemPtr := @ PCrackList( Result.fList ).fItems[ N - 1 ];
- {$ifdef cpu86}
- asm
- PUSH ESI
- PUSH EDI
- MOV ESI, FirstItemPtr
- MOV EDI, ESI
- STD
- MOV ECX, N
- XOR EAX, EAX
- CDQ
- @@1:
- PUSH ECX
- LODSD
- MOV ECX, Shift
- SHRD EAX, EDX, CL
- STOSD
- SUB ECX, 32
- NEG ECX
- SHR EDX, CL
- POP ECX
-
- LOOP @@1
-
- CLD
- POP EDI
- POP ESI
- end {$IFDEF F_P} ['EAX','EDX','ECX'] {$ENDIF};
- {$else}
- // FIXME
- MsgOK('TBits.Copy should be fixed.');
- Halt(7);
- {$endif cpu86}
- end;
- end;
-
- //[destructor TBits.Destroy]
- destructor TBits.Destroy;
- begin
- fList.Free;
- inherited;
- end;
-
- //[function TBits.GetBit]
- {$IFDEF ASM_VERSION}
- function TBits.GetBit(Idx: Integer): Boolean;
- asm
- CMP EDX, [EAX].FCount
- JL @@1
- XOR EAX, EAX
- RET
- @@1:
- MOV EAX, [EAX].fList
- {TEST EAX, EAX
- JZ @@exit}
- MOV EAX, [EAX].TList.fItems
- BT [EAX], EDX
- SETC AL
- @@exit:
- end;
- {$ELSE}
- function TBits.GetBit(Idx: Integer): Boolean;
- begin
- if (Idx >= Count) {or (PCrackList( fList ).fItems = nil)} then Result := FALSE else
- Result := ( ( DWORD( PCrackList( fList ).fItems[ Idx shr 5 ] ) shr (Idx and $1F)) and 1 ) <> 0;
- end;
- {$ENDIF}
-
- //[function TBits.GetCapacity]
- function TBits.GetCapacity: Integer;
- begin
- Result := fList.Capacity * 32;
- end;
-
- //[function TBits.GetSize]
- function TBits.GetSize: Integer;
- begin
- Result := ( PCrackList( fList ).fCount + 3) div 4;
- end;
-
- {$IFDEF ASM_noVERSION}
- //[function TBits.IndexOf]
- function TBits.IndexOf(Value: Boolean): Integer;
- asm //cmd //opd
- PUSH EDI
- MOV EDI, [EAX].fList
- MOV ECX, [EDI].TList.fCount
- @@ret_1:
- OR EAX, -1
- JECXZ @@ret_EAX
- MOV EDI, [EDI].TList.fItems
- TEST DL, DL
- MOV EDX, EDI
- JE @@of_false
- INC EAX
- REPZ SCASD
- JE @@ret_1
- MOV EAX, [EDI-4]
- NOT EAX
- JMP @@calc_offset
- BSF EAX, EAX
- SUB EDI, EDX
- SHR EDI, 2
- ADD EAX, EDI
- JMP @@ret_EAX
- @@of_false:
- REPE SCASD
- JE @@ret_1
- MOV EAX, [EDI-4]
- @@calc_offset:
- BSF EAX, EAX
- DEC EAX
- SUB EDI, 4
- SUB EDI, EDX
- SHL EDI, 3
- ADD EAX, EDI
- @@ret_EAX:
- POP EDI
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TBits.IndexOf(Value: Boolean): Integer;
- var I: Integer;
- D: DWORD;
- begin
- Result := -1;
- if Value then
- begin
- for I := 0 to fList.Count-1 do
- begin
- D := DWORD( PCrackList( fList ).fItems[ I ] );
- if D <> 0 then
- begin
- {$ifdef cpu86}
- asm
- MOV EAX, D
- BSF EAX, EAX
- MOV D, EAX
- end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
- {$else}
- // FIXME
- MsgOK('TBits.IndexOf should be fixed.');
- Halt(7);
- {$endif cpu86}
- Result := I * 32 + Integer( D );
- break;
- end;
- end;
- end
- else
- begin
- for I := 0 to PCrackList( fList ).fCount-1 do
- begin
- D := DWORD( PCrackList( fList ).fItems[ I ] );
- if D <> $FFFFFFFF then
- begin
- {$ifdef cpu86}
- asm
- MOV EAX, D
- NOT EAX
- BSF EAX, EAX
- MOV D, EAX
- end {$IFDEF F_P} [ 'EAX' ] {$ENDIF};
- {$else}
- // FIXME
- MsgOK('TBits.IndexOf should be fixed.');
- Halt(7);
- {$endif cpu86}
- Result := I * 32 + Integer( D );
- break;
- end;
- end;
- end;
- end;
- {$ENDIF ASM_VERSION}
-
- //[function TBits.LoadFromStream]
- procedure TBits.InstallBits(FromIdx, N: Integer; Value: Boolean);
- var NewCount: Integer;
- begin
- if FromIdx + N > fCount then
- begin
- Capacity := (FromIdx + N + 8) div 8;
- fCount := FromIdx + N - 1;
- end;
- NewCount := Max( Count, FromIdx + N - 1 );
- fCount := Max( NewCount, fCount );
- PCrackList( fList ).fCount := (Capacity + 3) div 4;
- while FromIdx and $1F <> 0 do
- begin
- Bits[ FromIdx ] := Value;
- Inc( FromIdx );
- Dec( N );
- if N = 0 then Exit;
- end;
- FillChar( PByte( cardinal( PCrackList( fList ).fItems ) + cardinal(FromIdx div 32) )^,
- (N + 7) div 8, -Integer( Value ) );
- end;
-
- function TBits.LoadFromStream(strm: PStream): Integer;
- var
- i: Integer;
- begin
- Result := strm.Read( i, 4 );
- if Result < 4 then Exit;
-
- bits[ i]:= false; //by miek
- fcount:= i;
-
- i := (i + 7) div 8;
- Inc( Result, strm.Read( PCrackList( fList ).fItems^, i ) );
- end;
-
- //[function TBits.OpenBit]
- function TBits.OpenBit: Integer;
- begin
- Result := IndexOf( FALSE );
- if Result < 0 then Result := Count;
- end;
-
- //[function TBits.Range]
- function TBits.Range(Idx, N: Integer): PBits;
- begin
- Result := NewBits;
- Result.AssignBits( 0, @ Self, Idx, N );
- end;
-
- //[function TBits.SaveToStream]
- function TBits.SaveToStream(strm: PStream): Integer;
- begin
- Result := strm.Write( fCount, 4 );
- if fCount = 0 then Exit;
- Inc( Result, strm.Write( PCrackList( fList ).fItems^, (fCount + 7) div 8 ) );
- end;
-
- //[procedure TBits.SetBit]
- {$IFDEF ASM_VERSION}
- procedure TBits.SetBit(Idx: Integer; const Value: Boolean);
- asm
- PUSH ECX
- MOV ECX, [EAX].fList
- MOV ECX, [ECX].TList.fCapacity
- SHL ECX, 5
- CMP EDX, ECX
- JLE @@1
-
- PUSH EDX
- INC EDX
- PUSH EAX
- CALL SetCapacity
- POP EAX
- POP EDX
-
- @@1:
- CMP EDX, [EAX].FCount
- JL @@2
- INC EDX
- MOV [EAX].fCount, EDX
- DEC EDX
- @@2:
- POP ECX
- MOV EAX, [EAX].fList
- MOV EAX, [EAX].TList.fItems
- SHR ECX, 1
- JC @@2set
- BTR [EAX], EDX
- JMP @@exit
- @@2set:
- BTS [EAX], EDX
- @@exit:
- end;
- {$ELSE}
- procedure TBits.SetBit(Idx: Integer; const Value: Boolean);
- var Msk: DWORD;
- begin
- if Idx >= Capacity then
- Capacity := Idx + 1;
- Msk := 1 shl (Idx and $1F);
- if Value then
- PCrackList( fList ).fItems[ Idx shr 5 ] := Pointer(
- DWORD(PCrackList( fList ).fItems[ Idx shr 5 ]) or Msk)
- else
- PCrackList( fList ).fItems[ Idx shr 5 ] := Pointer(
- DWORD(PCrackList( fList ).fItems[ Idx shr 5 ]) and not Msk);
- if Idx >= fCount then
- fCount := Idx + 1;
- end;
- {$ENDIF}
-
- //[procedure TBits.SetCapacity]
- procedure TBits.SetCapacity(const Value: Integer);
- var OldCap: Integer;
- begin
- OldCap := fList.Capacity;
- fList.Capacity := (Value + 31) div 32;
- if OldCap < fList.Capacity then
- FillChar( PChar( cardinal( PCrackList( fList ).fItems ) + cardinal(OldCap * Sizeof( Pointer )) )^,
- (fList.Capacity - OldCap) * sizeof( Pointer ), 0 );
- end;
-
- {------------------------------------------------------------------------------)
- | |
- | T F a s t S t r L i s t |
- | |
- (------------------------------------------------------------------------------}
-
- function NewFastStrListEx: PFastStrListEx;
- begin
- new( Result, Create );
- end;
-
- procedure InitUpper;
- var c: Char;
- begin
- for c := #0 to #255 do
- Upper[ c ] := AnsiUpperCase( c + #0 )[ 1 ];
- Upper_Initialized := TRUE;
- end;
-
- { TFastStrListEx }
-
- function TFastStrListEx.AddAnsi(const S: String): Integer;
- begin
- Result := AddObjectLen( PChar( S ), Length( S ), 0 );
- end;
-
- function TFastStrListEx.AddAnsiObject(const S: String; Obj: DWORD): Integer;
- begin
- Result := AddObjectLen( PChar( S ), Length( S ), Obj );
- end;
-
- function TFastStrListEx.Add(S: PChar): integer;
- begin
- Result := AddObjectLen( S, StrLen( S ), 0 )
- end;
-
- function TFastStrListEx.AddLen(S: PChar; Len: Integer): integer;
- begin
- Result := AddObjectLen( S, Len, 0 )
- end;
-
- function TFastStrListEx.AddObject(S: PChar; Obj: DWORD): Integer;
- begin
- Result := AddObjectLen( S, StrLen( S ), Obj )
- end;
-
- function TFastStrListEx.AddObjectLen(S: PChar; Len: Integer; Obj: DWORD): Integer;
- var Dest: PChar;
- begin
- ProvideSpace( Len + 9 );
- Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );
- Result := fCount;
- Inc( fCount );
- fList.Add( Pointer( DWORD(Dest)-DWORD(fTextBuf) ) );
- PDWORD( Dest )^ := Obj;
- Inc( Dest, 4 );
- PDWORD( Dest )^ := Len;
- Inc( Dest, 4 );
- if S <> nil then
- System.Move( S^, Dest^, Len );
- Inc( Dest, Len );
- Dest^ := #0;
- Inc( fUsedSiz, Len+9 );
- end;
-
- function TFastStrListEx.AppendToFile(const FileName: string): Boolean;
- var F: HFile;
- Txt: String;
- begin
- Txt := Text;
- F := FileCreate( FileName, ofOpenAlways or ofOpenReadWrite or ofShareDenyWrite );
- if F = INVALID_HANDLE_VALUE then Result := FALSE
- else begin
- FileSeek( F, 0, spEnd );
- Result := FileWrite( F, PChar( Txt )^, Length( Txt ) ) = DWORD( Length( Txt ) );
- FileClose( F );
- end;
- end;
-
- procedure TFastStrListEx.Clear;
- begin
- if FastClear then
- begin
- if fList.Count > 0 then
- PCrackList(fList).FCount := 0;
- end
- else
- begin
- fList.Clear;
- if fTextBuf <> nil then
- FreeMem( fTextBuf );
- fTextBuf := nil;
- end;
- fTextSiz := 0;
- fUsedSiz := 0;
- fCount := 0;
- end;
-
- procedure TFastStrListEx.Delete(Idx: integer);
- begin
- if (Idx < 0) or (Idx >= Count) then Exit;
- if Idx = Count-1 then
- Dec( fUsedSiz, ItemLen[ Idx ]+9 );
- fList.Delete( Idx );
- Dec( fCount );
- end;
-
- destructor TFastStrListEx.Destroy;
- begin
- FastClear := FALSE;
- Clear;
- fList.Free;
- inherited;
- end;
-
- function TFastStrListEx.Find(const S: String; var Index: Integer): Boolean;
- var i: Integer;
- begin
- for i := 0 to Count-1 do
- if (ItemLen[ i ] = Length( S )) and
- ((S = '') or CompareMem( ItemPtrs[ i ], @ S[ 1 ], Length( S ) )) then
- begin
- Index := i;
- Result := TRUE;
- Exit;
- end;
- Result := FALSE;
- end;
-
- function TFastStrListEx.Get(Idx: integer): string;
- begin
- if (Idx >= 0) and (Idx <= Count) then
- SetString( Result, PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 ),
- ItemLen[ Idx ] )
- else
- Result := '';
- end;
-
- function TFastStrListEx.GetItemLen(Idx: Integer): Integer;
- var Src: PDWORD;
- begin
- if (Idx >= 0) and (Idx <= Count) then
- begin
- Src := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 4 );
- Result := Src^
- end
- else Result := 0;
- end;
-
- function TFastStrListEx.GetObject(Idx: Integer): DWORD;
- var Src: PDWORD;
- begin
- if (Idx >= 0) and (Idx <= Count) then
- begin
- Src := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) );
- Result := Src^
- end
- else Result := 0;
- end;
-
- function TFastStrListEx.GetPChars(Idx: Integer): PChar;
- begin
- if (Idx >= 0) and (Idx <= Count) then
- Result := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 8 )
- else Result := nil;
- end;
-
- function TFastStrListEx.GetTextStr: string;
- var L, i: Integer;
- p: PChar;
- begin
- L := 0;
- for i := 0 to Count-1 do
- Inc( L, ItemLen[ i ] + 2 );
- SetLength( Result, L );
- p := PChar( Result );
- for i := 0 to Count-1 do
- begin
- L := ItemLen[ i ];
- if L > 0 then
- begin
- System.Move( ItemPtrs[ i ]^, p^, L );
- Inc( p, L );
- end;
- p^ := #13; Inc( p );
- p^ := #10; Inc( p );
- end;
- end;
-
- function TFastStrListEx.IndexOf(const S: string): integer;
- begin
- if not Find( S, Result ) then Result := -1;
- end;
-
- function TFastStrListEx.IndexOf_NoCase(const S: string): integer;
- begin
- Result := IndexOfStrL_NoCase( PChar( S ), Length( S ) );
- end;
-
- function TFastStrListEx.IndexOfStrL_NoCase(Str: PChar;
- L: Integer): integer;
- var i: Integer;
- begin
- for i := 0 to Count-1 do
- if (ItemLen[ i ] = L) and
- ((L = 0) or (StrLComp_NoCase( ItemPtrs[ i ], Str, L ) = 0)) then
- begin
- Result := i;
- Exit;
- end;
- Result := -1;
- end;
-
- procedure TFastStrListEx.Init;
- begin
- fList := NewList;
- FastClear := TRUE;
- end;
-
- procedure TFastStrListEx.InsertAnsi(Idx: integer; const S: String);
- begin
- InsertObjectLen( Idx, PChar( S ), Length( S ), 0 );
- end;
-
- procedure TFastStrListEx.InsertAnsiObject(Idx: integer; const S: String;
- Obj: DWORD);
- begin
- InsertObjectLen( Idx, PChar( S ), Length( S ), Obj );
- end;
-
- procedure TFastStrListEx.Insert(Idx: integer; S: PChar);
- begin
- InsertObjectLen( Idx, S, StrLen( S ), 0 )
- end;
-
- procedure TFastStrListEx.InsertLen(Idx: Integer; S: PChar; Len: Integer);
- begin
- InsertObjectLen( Idx, S, Len, 0 )
- end;
-
- procedure TFastStrListEx.InsertObject(Idx: Integer; S: PChar; Obj: DWORD);
- begin
- InsertObjectLen( Idx, S, StrLen( S ), Obj );
- end;
-
- procedure TFastStrListEx.InsertObjectLen(Idx: Integer; S: PChar;
- Len: Integer; Obj: DWORD);
- var Dest: PChar;
- begin
- ProvideSpace( Len+9 );
- Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );
- fList.Insert( Idx, Pointer( DWORD(Dest)-DWORD(fTextBuf) ) );
- PDWORD( Dest )^ := Obj;
- Inc( Dest, 4 );
- PDWORD( Dest )^ := Len;
- Inc( Dest, 4 );
- if S <> nil then
- System.Move( S^, Dest^, Len );
- Inc( Dest, Len );
- Dest^ := #0;
- Inc( fUsedSiz, Len+9 );
- Inc( fCount );
- end;
-
- function TFastStrListEx.Last: String;
- begin
- if Count > 0 then
- Result := Items[ Count-1 ]
- else
- Result := '';
- end;
-
- function TFastStrListEx.LoadFromFile(const FileName: string): Boolean;
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( FileName );
- TRY
- Result := Strm.Handle <> INVALID_HANDLE_VALUE;
- if Result then
- LoadFromStream( Strm, FALSE )
- else
- Clear;
- FINALLY
- Strm.Free;
- END;
- end;
-
- procedure TFastStrListEx.LoadFromStream(Stream: PStream;
- Append2List: boolean);
- var Txt: String;
- begin
- SetLength( Txt, Stream.Size - Stream.Position );
- Stream.Read( Txt[ 1 ], Stream.Size - Stream.Position );
- SetText( Txt, Append2List );
- end;
-
- procedure TFastStrListEx.MergeFromFile(const FileName: string);
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( FileName );
- TRY
- LoadFromStream( Strm, TRUE );
- FINALLY
- Strm.Free;
- END;
- end;
-
- procedure TFastStrListEx.Move(CurIndex, NewIndex: integer);
- begin
- Assert( (CurIndex >= 0) and (CurIndex < Count) and (NewIndex >= 0) and
- (NewIndex < Count), 'Item indexes violates TFastStrListEx range' );
- fList.MoveItem( CurIndex, NewIndex );
- end;
-
- procedure TFastStrListEx.ProvideSpace(AddSize: DWORD);
- var OldTextBuf: PChar;
- begin
- Inc( AddSize, 9 );
- if AddSize > fTextSiz - fUsedSiz then
- begin // óâåëè÷åíèå ðàçìåðà áóôåðà
- fTextSiz := Max( 1024, (fUsedSiz + AddSize) * 2 );
- OldTextBuf := fTextBuf;
- GetMem( fTextBuf, fTextSiz );
- if OldTextBuf <> nil then
- begin
- System.Move( OldTextBuf^, fTextBuf^, fUsedSiz );
- FreeMem( OldTextBuf );
- end;
- end;
- if fList.Count >= fList.Capacity then
- fList.Capacity := Max( 100, fList.Count * 2 );
- end;
-
- procedure TFastStrListEx.Put(Idx: integer; const Value: string);
- var Dest: PChar;
- OldLen: Integer;
- OldObj: DWORD;
- begin
- OldLen := ItemLen[ Idx ];
- if Length( Value ) <= OldLen then
- begin
- Dest := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) + 4 );
- PDWORD( Dest )^ := Length( Value );
- Inc( Dest, 4 );
- if Value <> '' then
- System.Move( Value[ 1 ], Dest^, Length( Value ) );
- Inc( Dest, Length( Value ) );
- Dest^ := #0;
- if Idx = Count-1 then
- Dec( fUsedSiz, OldLen - Length( Value ) );
- end
- else
- begin
- OldObj := 0;
- while Idx > Count do
- AddObjectLen( nil, 0, 0 );
- if Idx = Count-1 then
- begin
- OldObj := Objects[ Idx ];
- Delete( Idx );
- end;
- if Idx = Count then
- AddObjectLen( PChar( Value ), Length( Value ), OldObj )
- else
- begin
- ProvideSpace( Length( Value ) + 9 );
- Dest := PChar( DWORD( fTextBuf ) + fUsedSiz );
- fList.Items[ Idx ] := Pointer( DWORD(Dest)-DWORD(fTextBuf) );
- Inc( Dest, 4 );
- PDWORD( Dest )^ := Length( Value );
- Inc( Dest, 4 );
- if Value <> '' then
- System.Move( Value[ 1 ], Dest^, Length( Value ) );
- Inc( Dest, Length( Value ) );
- Dest^ := #0;
- Inc( fUsedSiz, Length( Value )+9 );
- end;
- end;
- end;
-
- function TFastStrListEx.SaveToFile(const FileName: string): Boolean;
- var Strm: PStream;
- begin
- Strm := NewWriteFileStream( FileName );
- TRY
- if Strm.Handle <> INVALID_HANDLE_VALUE then
- SaveToStream( Strm );
- Result := TRUE;
- FINALLY
- Strm.Free;
- END;
- end;
-
- procedure TFastStrListEx.SaveToStream(Stream: PStream);
- var Txt: String;
- begin
- Txt := Text;
- Stream.Write( PChar( Txt )^, Length( Txt ) );
- end;
-
- procedure TFastStrListEx.SetObject(Idx: Integer; const Value: DWORD);
- var Dest: PDWORD;
- begin
- if Idx < 0 then Exit;
- while Idx >= Count do
- AddObjectLen( nil, 0, 0 );
- Dest := PDWORD( DWORD( fTextBuf ) + DWORD( fList.Items[ Idx ] ) );
- Dest^ := Value;
- end;
-
- procedure TFastStrListEx.SetText(const S: string; Append2List: boolean);
- var Len2Add, NLines, L: Integer;
- p0, p: PChar;
- begin
- if not Append2List then Clear;
- // ïîäñ÷åò òðåáóåìîãî ïðîñòðàíñòâà
- Len2Add := 0;
- NLines := 0;
- p := Pchar( S );
- p0 := p;
- L := Length( S );
- while L > 0 do
- begin
- if p^ = #13 then
- begin
- Inc( NLines );
- Inc( Len2Add, 9 + DWORD(p)-DWORD(p0) );
- REPEAT Inc( p ); Dec( L );
- UNTIL (p^ <> #10) or (L = 0);
- p0 := p;
- end
- else
- begin
- Inc( p ); Dec( L );
- end;
- end;
- if DWORD(p) > DWORD(p0) then
- begin
- Inc( NLines );
- Inc( Len2Add, 9 + DWORD(p)-DWORD(p0) );
- end;
- if Len2Add = 0 then Exit;
- // äîáàâëåíèå
- ProvideSpace( Len2Add - 9 );
- if fList.Capacity <= fList.Count + NLines then
- fList.Capacity := Max( (fList.Count + NLines) * 2, 100 );
- p := PChar( S );
- p0 := p;
- L := Length( S );
- while L > 0 do
- begin
- if p^ = #13 then
- begin
- AddObjectLen( p0, DWORD(p)-DWORD(p0), 0 );
- REPEAT Inc( p ); Dec( L );
- UNTIL (p^ <> #10) or (L = 0);
- p0 := p;
- end
- else
- begin
- Inc( p ); Dec( L );
- end;
- end;
- if DWORD(p) > DWORD(p0) then
- AddObjectLen( p0, DWORD(p)-DWORD(p0), 0 );
- end;
-
- procedure TFastStrListEx.SetTextStr(const Value: string);
- begin
- SetText( Value, FALSE );
- end;
-
- function CompareFast(const Data: Pointer; const e1,e2 : Dword) : Integer;
- var FSL: PFastStrListEx;
- L1, L2: Integer;
- S1, S2: PChar;
- begin
- FSL := Data;
- S1 := FSL.ItemPtrs[ e1 ];
- S2 := FSL.ItemPtrs[ e2 ];
- L1 := FSL.ItemLen[ e1 ];
- L2 := FSL.ItemLen[ e2 ];
- if FSL.fCaseSensitiveSort then
- Result := StrLComp( S1, S2, Min( L1, L2 ) )
- else
- Result := StrLComp_NoCase( S1, S2, Min( L1, L2 ) );
- if Result = 0 then
- Result := L1 - L2;
- if Result = 0 then
- Result := e1 - e2;
- end;
-
- procedure SwapFast(const Data : Pointer; const e1,e2 : Dword);
- var FSL: PFastStrListEx;
- begin
- FSL := Data;
- FSL.Swap( e1, e2 );
- end;
-
- procedure TFastStrListEx.Sort(CaseSensitive: Boolean);
- begin
- fCaseSensitiveSort := CaseSensitive;
- SortData( @ Self, Count, CompareFast, SwapFast );
- end;
-
- procedure TFastStrListEx.Swap(Idx1, Idx2: Integer);
- begin
- Assert( (Idx1 >= 0) and (Idx1 <= Count-1) and (Idx2 >= 0) and (Idx2 <= Count-1),
- 'Item indexes violates TFastStrListEx range' );
- fList.Swap( Idx1, Idx2 );
- end;
-
- function TFastStrListEx.GetValues(AName: PChar): PChar;
- var i: Integer;
- s, n: PChar;
- begin
- if not Upper_Initialized then
- InitUpper;
- for i := 0 to Count-1 do
- begin
- s := ItemPtrs[ i ];
- n := AName;
- while (Upper[ s^ ] = Upper[ n^ ]) and (s^ <> '=') and (s^ <> #0) and (n^ <> #0) do
- begin
- Inc( s );
- Inc( n );
- end;
- if (s^ = '=') and (n^ = #0) then
- begin
- Result := s;
- Inc( Result );
- Exit;
- end;
- end;
- Result := nil;
- end;
-
- function TFastStrListEx.IndexOfName(AName: PChar): Integer;
- var i: Integer;
- s, n: PChar;
- begin
- if not Upper_Initialized then
- InitUpper;
- for i := 0 to Count-1 do
- begin
- s := ItemPtrs[ i ];
- n := AName;
- while (Upper[ s^ ] = Upper[ n^ ]) and (s^ <> '=') and (s^ <> #0) and (n^ <> #0) do
- begin
- Inc( s );
- Inc( n );
- end;
- if (s^ = '=') and (n^ = #0) then
- begin
- Result := i;
- Exit;
- end;
- end;
- Result := -1;
- end;
-
- procedure TFastStrListEx.Append(S: PChar);
- begin
- AppendLen( S, StrLen( S ) );
- end;
-
- procedure TFastStrListEx.AppendInt2Hex(N: DWORD; MinDigits: Integer);
- var Buffer: array[ 0..9 ] of Char;
- Mask: DWORD;
- i, Len: Integer;
- B: Byte;
- begin
- if MinDigits > 8 then
- MinDigits := 8;
- if MinDigits <= 0 then
- MinDigits := 1;
- Mask := $F0000000;
- for i := 8 downto MinDigits do
- begin
- if Mask and N <> 0 then
- begin
- MinDigits := i;
- break;
- end;
- Mask := Mask shr 4;
- end;
- i := 0;
- Len := MinDigits;
- Mask := $F shl ((Len - 1)*4);
- while MinDigits > 0 do
- begin
- Dec( MinDigits );
- B := (N and Mask) shr (MinDigits * 4);
- Mask := Mask shr 4;
- if B <= 9 then
- Buffer[ i ] := Char( B + Ord( '0' ) )
- else
- Buffer[ i ] := Char( B + Ord( 'A' ) - 10 );
- Inc( i );
- end;
- Buffer[ i ] := #0;
- AppendLen( @ Buffer[ 0 ], Len );
- end;
-
- procedure TFastStrListEx.AppendLen(S: PChar; Len: Integer);
- var Dest: PChar;
- begin
- if Count = 0 then
- AddLen( S, Len )
- else
- begin
- ProvideSpace( Len );
- Dest := PChar( DWORD( fTextBuf ) + fUsedSiz - 1 );
- System.Move( S^, Dest^, Len );
- Inc( Dest, Len );
- Dest^ := #0;
- Inc( fUsedSiz, Len );
- Dest := PChar( DWORD( fTextBuf ) + DWORD( fList.Items[ Count-1 ] ) );
- Inc( Dest, 4 );
- PDWORD( Dest )^ := PDWORD( Dest )^ + DWORD( Len );
- end;
- end;
-
-
- { TCABFile }
-
- //[function OpenCABFile]
- function OpenCABFile( const APaths: array of String ): PCABFile;
- var I: Integer;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PCABFile.Create;*){--}
- Result.FSetupapi := LoadLibrary( 'setupapi.dll' );
- Result.FNames := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
- Result.FPaths := {$IFDEF UNICODE_CTRLS} NewWStrList {$ELSE} NewStrList {$ENDIF};
- for I := 0 to High( APaths ) do
- Result.FPaths.Add( APaths[ I ] );
- end;
-
- //[destructor TCABFile.Destroy]
- destructor TCABFile.Destroy;
- begin
- FNames.Free;
- FPaths.Free;
- FTargetPath := '';
- if FSetupapi <> 0 then
- FreeLibrary( FSetupapi );
- inherited;
- end;
-
- const
- SPFILENOTIFY_FILEINCABINET = $11;
- SPFILENOTIFY_NEEDNEWCABINET = $12;
-
- type
- PSP_FILE_CALLBACK = function( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;
- stdcall;
-
- TSetupIterateCabinet = function ( CabinetFile: PKOLChar; Reserved: DWORD;
- MsgHandler: PSP_FILE_CALLBACK; Context: Pointer ): Boolean; stdcall;
- //external 'setupapi.dll' name 'SetupIterateCabinetA';
-
- TSetupPromptDisk = function (
- hwndParent: HWND; // parent window of the dialog box
- DialogTitle: PKOLChar; // optional, title of the dialog box
- DiskName: PKOLChar; // optional, name of disk to insert
- PathToSource: PKOLChar;// optional, expected source path
- FileSought: PKOLChar; // name of file needed
- TagFile: PKOLChar; // optional, source media tag file
- DiskPromptStyle: DWORD; // specifies dialog box behavior
- PathBuffer: PKOLChar; // receives the source location
- PathBufferSize: DWORD; // size of the supplied buffer
- PathRequiredSize: PDWORD // optional, buffer size needed
- ): DWORD; stdcall;
- //external 'setupapi.dll' name 'SetupPromptForDiskA';
-
- type
- TCabinetInfo = packed record
- CabinetPath: PKOLChar;
- CabinetFile: PKOLChar;
- DiskName: PKOLChar;
- SetId: WORD;
- CabinetNumber: WORD;
- end;
- PCabinetInfo = ^TCabinetInfo;
-
- TFileInCabinetInfo = packed record
- NameInCabinet: PKOLChar;
- FileSize: DWORD;
- Win32Error: DWORD;
- DosDate: WORD;
- DosTime: WORD;
- DosAttribs: WORD;
- FullTargetName: array[0..MAX_PATH-1] of KOLChar;
- end;
- PFileInCabinetInfo = ^TFileInCabinetInfo;
-
- //[function CABCallback]
- function CABCallback( Context: Pointer; Notification, Param1, Param2: DWORD ): DWORD;
- stdcall;
- var CAB: PCABFile;
- CABPath, OldPath: KOLString;
- CABInfo: PCabinetInfo;
- CABFileInfo: PFileInCabinetInfo;
- hr: Integer;
- SetupPromptProc: TSetupPromptDisk;
- begin
- Result := 0;
- CAB := Context;
- case Notification of
- SPFILENOTIFY_NEEDNEWCABINET:
- begin
- OldPath := CAB.FPaths.Items[ CAB.FCurCAB ];
- Inc( CAB.FCurCAB );
- if CAB.FCurCAB = CAB.FPaths.Count then
- CAB.FPaths.Add( '?' );
- CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];
- if CABPath = '?' then
- begin
- if Assigned( CAB.FOnNextCAB ) then
- CAB.FPaths.Items[CAB.FCurCAB ] := CAB.FOnNextCAB( CAB );
- CABPath := CAB.FPaths.Items[ CAB.FCurCAB ];
- if CABPath = '?' then
- begin
- SetLength( CABPath, MAX_PATH );
- CABInfo := Pointer( Param1 );
- if CAB.FSetupapi <> 0 then
- SetupPromptProc := GetProcAddress( CAB.FSetupapi, 'SetupPromptForDiskA' )
- else
- SetupPromptProc := nil;
- if Assigned( SetupPromptProc ) then
- begin
- hr := SetupPromptProc( 0, nil, nil, PKOLChar( ExtractFilePath( OldPath ) ),
- CABInfo.CabinetFile, nil, 2 {IDF_NOSKIP}, @CabPath[ 1 ], MAX_PATH, nil );
- case hr of
- 0: // success
- begin
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- ( PKOLChar( Param2 ), PKOLChar( CABPath ) );
- Result := 0;
- end;
- 2: // skip file
- Result := 0;
- else // cancel
- Result := ERROR_FILE_NOT_FOUND;
- end;
- end;
- end
- else
- begin
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- ( PKOLChar( Param2 ), PKOLChar( CABPath ) );
- Result := 0;
- end;
- end;
- end;
- SPFILENOTIFY_FILEINCABINET:
- begin
- CABFileInfo := Pointer( Param1 );
- if CAB.FGettingNames then
- begin
- CAB.FNames.Add( CABFileInfo.NameInCabinet );
- Result := 2; // FILEOP_SKIP
- end
- else
- begin
- CABPath := CABFileInfo.NameInCabinet;
- if Assigned( CAB.FOnFile ) then
- begin
- if CAB.FOnFile( CAB, CABPath ) then
- begin
- if ExtractFilePath( CABPath ) = '' then
- if CAB.FTargetPath <> '' then
- CABPath := CAB.TargetPath + CABPath;
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- ( @CABFileInfo.FullTargetName[ 0 ], PKOLChar( CABPath ) );
- Result := 1; // FILEOP_DOIT
- end
- else
- Result := 2
- end
- else
- begin
- if CAB.FTargetPath <> '' then
- {$IFDEF UNICODE_CTRLS} WStrCopy {$ELSE} StrCopy {$ENDIF}
- ( @CABFileInfo.FullTargetName[ 0 ],
- PKOLChar( CAB.TargetPath + CABPath ) );
- Result := 1;
- end;
- end;
- end;
- end;
- end;
-
- //[function TCABFile.Execute]
- function TCABFile.Execute: Boolean;
- var SetupIterateProc: TSetupIterateCabinet;
- begin
- FCurCAB := 0;
- Result := FALSE;
- if FSetupapi = 0 then Exit;
- SetupIterateProc := GetProcAddress( FSetupapi, 'SetupIterateCabinetA' );
- if not Assigned( SetupIterateProc ) then Exit;
- Result := SetupIterateProc( PKOLChar( KOLString( FPaths.Items[ 0 ] ) ),
- 0, CABCallback, @Self );
- end;
-
- //[function TCABFile.GetCount]
- function TCABFile.GetCount: Integer;
- begin
- GetNames( 0 );
- Result := FNames.Count;
- end;
-
- //[function TCABFile.GetNames]
- function TCABFile.GetNames(Idx: Integer): KOLString;
- begin
- if FNames.Count = 0 then
- begin
- FGettingNames := TRUE;
- Execute;
- FGettingNames := FALSE;
- end;
- Result := '';
- if Idx < FNames.Count then
- Result := FNames.Items[ Idx ];
- end;
-
- //[function TCABFile.GetPaths]
- function TCABFile.GetPaths(Idx: Integer): KOLString;
- begin
- Result := FPaths.Items[ Idx ];
- end;
-
- //[function TCABFile.GetTargetPath]
- function TCABFile.GetTargetPath: KOLString;
- begin
- Result := FTargetPath;
- if Result <> '' then
- if Result[ Length( Result ) ] <> '\' then
- Result := Result + '\';
- end;
-
- { -- TDirChange -- }
-
- const FilterFlags: array[ TFileChangeFilters ] of Integer = (
- FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,
- FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,
- FILE_NOTIFY_CHANGE_LAST_WRITE, $20 {FILE_NOTIFY_CHANGE_LAST_ACCESS},
- $40 {FILE_NOTIFY_CHANGE_CREATION}, FILE_NOTIFY_CHANGE_SECURITY );
-
- //[FUNCTION _NewDirChgNotifier]
- {$IFDEF ASM_VERSION}
- function _NewDirChgNotifier: PDirChange;
- begin
- New( Result, Create );
- end;
- //[function NewDirChangeNotifier]
- function NewDirChangeNotifier( const Path: String; Filter: TFileChangeFilter;
- WatchSubtree: Boolean; ChangeProc: TOnDirChange )
- : PDirChange;
- const Dflt_Flags = FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or
- FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or
- FILE_NOTIFY_CHANGE_LAST_WRITE;
- asm
- PUSH EBX
- PUSH ECX // [EBP-8] = WatchSubtree
- PUSH EDX // [EBP-12] = Filter
- PUSH EAX // [EBP-16] = Path
- CALL _NewDirChgNotifier
- XCHG EBX, EAX
- LEA EAX, [EBX].TDirChange.FPath
- POP EDX
- CALL System.@LStrAsg
- MOV EAX, [ChangeProc].TMethod.Code
- MOV [EBX].TDirChange.FOnChange.TMethod.Code, EAX
- MOV EAX, [ChangeProc].TMethod.Data
- MOV [EBX].TDirChange.FOnChange.TMethod.Data, EAX
- POP ECX
- MOV EAX, Dflt_Flags
- MOVZX ECX, CL
- JECXZ @@flags_ready
- PUSH ECX
- MOV EAX, ESP
- MOV EDX, offset[FilterFlags]
- XOR ECX, ECX
- MOV CL, 7
- CALL MakeFlags
- POP ECX
- @@flags_ready: // EAX = Flags
- POP EDX
- MOVZX EDX, DL // EDX = WatchSubtree
- PUSH EAX
- PUSH EDX
- PUSH [EBX].TDirChange.FPath
- CALL FindFirstChangeNotification
- MOV [EBX].TDirChange.FHandle, EAX
- INC EAX
- JZ @@fault
- PUSH EBX
- PUSH offset[TDirChange.Execute]
- CALL NewThreadEx
- MOV [EBX].TDirChange.FMonitor, EAX
- JMP @@exit
- @@fault:
- XCHG EAX, EBX
- CALL TObj.Free
- @@exit:
- XCHG EAX, EBX
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function NewDirChangeNotifier( const Path: KOLString; Filter: TFileChangeFilter;
- WatchSubtree: Boolean; ChangeProc: TOnDirChange )
- : PDirChange;
- var Flags: DWORD;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PDirChange.Create;*){--}
-
- Result.FPath := Path;
- Result.FOnChange := ChangeProc;
- if Filter = [ ] then
- Flags := FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or
- FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or
- FILE_NOTIFY_CHANGE_LAST_WRITE
- else
- Flags := MakeFlags( @Filter, FilterFlags );
- Result.FinEvent := CreateEvent( nil, TRUE, FALSE, nil );
- Result.FHandle := FindFirstChangeNotification(PKOLChar(Result.FPath),
- Bool( Integer( WatchSubtree ) ), Flags);
- if Result.FHandle <> INVALID_HANDLE_VALUE then
- Result.FMonitor := NewThreadAutoFree( Result.Execute )
- else //MsgOK( 'Can not monitor ' + Result.FPath + #13'Error ' + Int2Str( GetLastError ) );
- begin
- Result.Free;
- Result := nil;
- end;
- end;
- {$ENDIF ASM_VERSION}
- //[END _NewDirChgNotifier]
-
- { TDirChange }
-
- {$IFDEF ASM_VERSION}
- //[procedure TDirChange.Changed]
- procedure TDirChange.Changed;
- asm
- MOV ECX, [EAX].FOnChange.TMethod.Code
- JECXZ @@exit
- MOV ECX, [EAX].FPath
- XCHG EDX, EAX
- MOV EAX, [EDX].FOnChange.TMethod.Data
- CALL [EDX].FOnChange.TMethod.Code
- @@exit:
- end;
- {$ELSE ASM_VERSION} //Pascal
- procedure TDirChange.Changed;
- begin
- if Assigned( FOnChange ) then
- FOnChange(@Self, FPath);
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_VERSION}
- //[destructor TDirChange.Destroy]
- destructor TDirChange.Destroy;
- asm
- PUSH EBX
- XCHG EBX, EAX
- MOV ECX, [EBX].FMonitor
- JECXZ @@no_monitor
- XCHG EAX, ECX
- CALL TObj.Free
- @@no_monitor:
- MOV ECX, [EBX].FHandle
- JECXZ @@exit
- PUSH ECX
- CALL FindCloseChangeNotification
- @@exit:
- LEA EAX, [EBX].FPath
- CALL System.@LStrClr
- XCHG EAX, EBX
- CALL TObj.Destroy
- POP EBX
- end;
- {$ELSE ASM_VERSION} //Pascal
- destructor TDirChange.Destroy;
- begin
- if FHandle > 0 then // FHandle <> INVALID_HANDLE_VALUE AND FHandle <> 0
- begin
- OnChange := nil;
- SetEvent( FinEvent );
- end;
- //if FMonitor <> nil then
- // FMonitor.Free;
- FPath := '';
- inherited;
- end;
- {$ENDIF ASM_VERSION}
-
- {$IFDEF ASM_noVERSION}
- //[function TDirChange.Execute]
- function TDirChange.Execute(Sender: PThread): Integer;
- asm
- PUSH EBX
- PUSH ESI
- XCHG EBX, EAX
- MOV ESI, EDX
- @@loo:
- MOVZX ECX, [ESI].TThread.FTerminated
- INC ECX
- LOOP @@e_loop
-
- MOV ECX, [EBX].FHandle
- INC ECX
- JZ @@e_loop
-
- PUSH INFINITE
- PUSH ECX
- CALL WaitForSingleObject
- OR EAX, EAX
- JNZ @@loo
-
- PUSH [EBX].FHandle
- MOV EAX, [EBX].FMonitor
- PUSH EBX
- PUSH offset[TDirChange.Changed]
- CALL TThread.Synchronize
- CALL FindNextChangeNotification
- JMP @@loo
- @@e_loop:
-
- POP ESI
- POP EBX
- XOR EAX, EAX
- end;
- {$ELSE ASM_VERSION} //Pascal
- function TDirChange.Execute(Sender: PThread): Integer;
- var Handles: array[ 0..1 ] of THandle;
- //i: Integer;
- begin
- Handles[ 0 ] := FHandle;
- Handles[ 1 ] := FinEvent;
- while TRUE do
- case WaitForMultipleObjects(2, @ Handles[ 0 ], FALSE, INFINITE) of
- WAIT_OBJECT_0:
- begin
- if AppletTerminated then break;
- Applet.GetWindowHandle;
- Sender.Synchronize( Changed );
- FindNextChangeNotification(Handles[ 0 ]);
- {for i := 1 to 10 do
- begin
- Sleep( 10 );
- if AppletTerminated then break;
- end;}
- end;
- else break;
- end;
- {$IFDEF SAFE_CODE}
- TRY
- {$ENDIF}
- FindCloseChangeNotification( Handles[ 0 ] );
- CloseHandle( Handles[ 1 ] );
- {$IFDEF SAFE_CODE}
- EXCEPT
- END;
- {$ENDIF}
- Result := 0;
- end;
- {$ENDIF ASM_VERSION}
-
- {$ifdef win32}
- ////////////////////////////////////////////////////////////////////////
- //
- //
- // M E T A F I L E
- //
- //
- ////////////////////////////////////////////////////////////////////////
-
- {++}(*
- //[API SetEnhMetaFileBits]
- function SetEnhMetaFileBits; external gdi32 name 'SetEnhMetaFileBits';
- function PlayEnhMetaFile; external gdi32 name 'PlayEnhMetaFile';
- *){--}
-
- //[function NewMetafile]
- function NewMetafile: PMetafile;
- begin
- {-}
- new( Result, Create );
- {+}{++}(*Result := PMetafile.Create;*){--}
- end;
- //[END NewMetafile]
-
- { TMetafile }
-
- //[procedure TMetafile.Clear]
- procedure TMetafile.Clear;
- begin
- if fHandle <> 0 then
- DeleteEnhMetaFile( fHandle );
- fHandle := 0;
- end;
-
- //[destructor TMetafile.Destroy]
- destructor TMetafile.Destroy;
- begin
- if fHeader <> nil then
- FreeMem( fHeader );
- Clear;
- inherited;
- end;
-
- //[procedure TMetafile.Draw]
- procedure TMetafile.Draw(DC: HDC; X, Y: Integer);
- begin
- StretchDraw( DC, MakeRect( X, Y, X + Width, Y + Height ) );
- end;
-
- //[function TMetafile.Empty]
- function TMetafile.Empty: Boolean;
- begin
- Result := fHandle = 0;
- end;
-
- //[function TMetafile.GetHeight]
- function TMetafile.GetHeight: Integer;
- begin
- Result := 0;
- if Empty then Exit;
- RetrieveHeader;
- Result := fHeader.rclBounds.Bottom - fHeader.rclBounds.Top;
- //Result := fHeader.rclFrame.Bottom - fHeader.rclFrame.Top;
- end;
-
- //[function TMetafile.GetWidth]
- function TMetafile.GetWidth: Integer;
- begin
- Result := 0;
- if Empty then Exit;
- RetrieveHeader;
- Result := fHeader.rclBounds.Right - fHeader.rclBounds.Left;
- //Result := fHeader.rclFrame.Right - fHeader.rclFrame.Left;
- end;
-
- //[function TMetafile.LoadFromFile]
- function TMetafile.LoadFromFile(const Filename: String): Boolean;
- var Strm: PStream;
- begin
- Strm := NewReadFileStream( FileName );
- Result := LoadFromStream( Strm );
- Strm.Free;
- end;
-
- //[function ComputeAldusChecksum]
- function ComputeAldusChecksum(var WMF: TMetafileHeader): Word;
- type
- PWord = ^Word;
- var
- pW: PWord;
- pEnd: PWord;
- begin
- Result := 0;
- pW := @WMF;
- pEnd := @WMF.CheckSum;
- while cardinal(pW) < cardinal(pEnd) do
- begin
- Result := Result xor pW^;
- Inc(Longint(pW), SizeOf(Word));
- end;
- end;
-
- //[function TMetafile.LoadFromStream]
- function TMetafile.LoadFromStream(Strm: PStream): Boolean;
- var WMF: TMetaFileHeader;
- WmfHdr: TMetaHeader;
- EnhHdr: TEnhMetaHeader;
- Pos, Pos1: Integer;
- Sz: Integer;
- MemStrm: PStream;
- MFP: TMetafilePict;
- begin
- Result := FALSE;
- Pos := Strm.Position;
-
- if Strm.Read( WMF, Sizeof( WMF ) ) <> Sizeof( WMF ) then
- begin
- Strm.Position := Pos;
- Exit;
- end;
-
- MemStrm := NewMemoryStream;
-
- if WMF.Key = WMFKey then
- begin // Windows metafile
-
- if WMF.CheckSum <> ComputeAldusChecksum( WMF ) then
- begin
- Strm.Position := Pos;
- Exit;
- end;
-
- Pos1 := Strm.Position;
- if Strm.Read( WmfHdr, Sizeof( WmfHdr ) ) <> Sizeof( WmfHdr ) then
- begin
- Strm.Position := Pos;
- Exit;
- end;
-
- Strm.Position := Pos1;
- Sz := WMFHdr.mtSize * 2;
- Stream2Stream( MemStrm, Strm, Sz );
- FillChar( MFP, Sizeof( MFP ), 0 );
- MFP.mm := MM_ANISOTROPIC;
- fHandle := SetWinMetafileBits( Sz, MemStrm.Memory, 0, MFP );
-
- end
- else
- begin // may be enchanced?
-
- Strm.Position := Pos;
- if Strm.Read( EnhHdr, Sizeof( EnhHdr ) ) < 8 then
- begin
- Strm.Position := Pos;
- Exit;
- end;
- // yes, enchanced
- Strm.Position := Pos;
- Sz := EnhHdr.nBytes;
- Stream2Stream( MemStrm, Strm, Sz );
- fHandle := SetEnhMetaFileBits( Sz, MemStrm.Memory );
-
- end;
-
- MemStrm.Free;
- Result := fHandle <> 0;
- if not Result then
- Strm.Position := Pos;
-
- end;
-
- //[procedure TMetafile.RetrieveHeader]
- procedure TMetafile.RetrieveHeader;
- var SzHdr: Integer;
- begin
- if fHeader = nil then
- begin
- SzHdr := GetEnhMetaFileHeader( fHandle, 0, nil );
- fHeader := AllocMem( { SzHeader } Sizeof( fHeader^ ) );
- fHeader.iType := EMR_HEADER;
- fHeader.nSize := Sizeof( fHeader^ ) { SzHdr };
- GetEnhMetaFileHeader( fHandle, SzHdr, fHeader );
- end;
- end;
-
- //[procedure TMetafile.SetHandle]
- procedure TMetafile.SetHandle(const Value: THandle);
- begin
- Clear;
- fHandle := Value;
- end;
-
- //[procedure TMetafile.StretchDraw]
- procedure TMetafile.StretchDraw(DC: HDC; const R: TRect);
- begin
- if Empty then Exit;
- PlayEnhMetaFile( DC, fHandle, R );
- {if not PlayEnhMetaFile( DC, fHandle, R ) then
- begin
- ShowMessage( SysErrorMessage( GetLastError ) );
- end;}
- end;
- {$endif win32}
-
- { ----------------------------------------------------------------------
-
- TAction and TActionList
-
- ----------------------------------------------------------------------- }
- //[function NewActionList]
- function NewActionList(AOwner: PControl): PActionList;
- begin
- {-}
- New( Result, Create );
- {+} {++}(* Result := PActionList.Create; *){--}
- with Result{-}^{+} do begin
- FActions:=NewList;
- FOwner:=AOwner;
- {$ifdef USE_OnIdle}
- RegisterIdleHandler(DoUpdateActions);
- {$endif USE_OnIdle}
- end;
- end;
- //[END NewActionList]
-
- //[function NewAction]
- function NewAction(const ACaption, AHint: string; AOnExecute: TOnEvent): PAction;
- begin
- {-}
- New( Result, Create );
- {+} {++}(* Result := PAction.Create; *){--}
- with Result{-}^{+} do begin
- FControls:=NewList;
- Enabled:=True;
- Visible:=True;
- Caption:=ACaption;
- Hint:=AHint;
- OnExecute:=AOnExecute;
- end;
- end;
- //[END NewAction]
-
- { TAction }
-
- //[procedure TAction.LinkCtrl]
- procedure TAction.LinkCtrl(ACtrl: PObj; ACtrlKind: TCtrlKind; AItemID: integer; AUpdateProc: TOnUpdateCtrlEvent);
- var
- cr: PControlRec;
- begin
- New(cr);
- with cr^ do begin
- Ctrl:=ACtrl;
- CtrlKind:=ACtrlKind;
- ItemID:=AItemID;
- UpdateProc:=AUpdateProc;
- end;
- FControls.Add(cr);
- FUpdateMask:=[upCaption, upHint, upChecked, upEnabled, upVisible, upHelpContext, upAccelerator];
- AUpdateProc(cr);
- FUpdateMask:=[];
- end;
-
- //[procedure TAction.LinkControl]
- procedure TAction.LinkControl(Ctrl: PControl);
- begin
- LinkCtrl(Ctrl, ckControl, 0, UpdateCtrl);
- Ctrl.OnClick:=DoOnControlClick;
- end;
-
- //[procedure TAction.LinkMenuItem]
- procedure TAction.LinkMenuItem(Menu: PMenu; MenuItemIdx: integer);
- {$IFDEF _FPC}
- var
- arr1_DoOnMenuItem: array[ 0..0 ] of TOnMenuItem;
- {$ENDIF _FPC}
- begin
- LinkCtrl(Menu, ckMenu, MenuItemIdx, UpdateMenu);
- {$IFDEF _FPC}
- arr1_DoOnMenuItem[ 0 ] := DoOnMenuItem;
- Menu.AssignEvents(MenuItemIdx, arr1_DoOnMenuItem);
- {$ELSE}
- Menu.AssignEvents(MenuItemIdx, [ DoOnMenuItem ]);
- {$ENDIF}
- end;
-
- //[procedure TAction.LinkToolbarButton]
- procedure TAction.LinkToolbarButton(Toolbar: PControl; ButtonIdx: integer);
- {$IFDEF _FPC}
- var
- arr1_DoOnToolbarButtonClick: array[ 0..0 ] of TOnToolbarButtonClick;
- {$ENDIF _FPC}
- begin
- LinkCtrl(Toolbar, ckToolbar, ButtonIdx, UpdateToolbar);
- {$IFDEF _FPC}
- arr1_DoOnToolbarButtonClick[ 0 ] := DoOnToolbarButtonClick;
- Toolbar.TBAssignEvents(ButtonIdx, arr1_DoOnToolbarButtonClick);
- {$ELSE}
- Toolbar.TBAssignEvents(ButtonIdx, [DoOnToolbarButtonClick]);
- {$ENDIF}
- end;
-
- //[destructor TAction.Destroy]
- destructor TAction.Destroy;
- begin
- FControls.Release;
- FCaption:='';
- {$ifndef wince}
- FShortCut:='';
- {$endif wince}
- FHint:='';
- inherited;
- end;
-
- //[procedure TAction.DoOnControlClick]
- procedure TAction.DoOnControlClick(Sender: PObj);
- begin
- Execute;
- end;
-
- //[procedure TAction.DoOnMenuItem]
- procedure TAction.DoOnMenuItem(Sender: PMenu; Item: Integer);
- begin
- Execute;
- end;
-
- //[procedure TAction.DoOnToolbarButtonClick]
- procedure TAction.DoOnToolbarButtonClick(Sender: PControl; BtnID: Integer);
- begin
- Execute;
- end;
-
- //[procedure TAction.Execute]
- procedure TAction.Execute;
- begin
- if Assigned(FOnExecute) and FEnabled then
- FOnExecute(PObj( @Self ));
- end;
-
- //[procedure TAction.SetCaption]
- procedure TAction.SetCaption(const Value: KOLstring);
- begin
- if Caption = Value then exit;
- FCaption:=Value;
- Include(FUpdateMask, upCaption);
- UpdateControls;
- end;
-
- //[procedure TAction.SetChecked]
- procedure TAction.SetChecked(const Value: boolean);
- begin
- if FChecked = Value then exit;
- FChecked := Value;
- Include(FUpdateMask, upChecked);
- UpdateControls;
- end;
-
- //[procedure TAction.SetEnabled]
- procedure TAction.SetEnabled(const Value: boolean);
- begin
- if FEnabled = Value then exit;
- FEnabled := Value;
- Include(FUpdateMask, upEnabled);
- UpdateControls;
- end;
-
- //[procedure TAction.SetHelpContext]
- procedure TAction.SetHelpContext(const Value: integer);
- begin
- if FHelpContext = Value then exit;
- FHelpContext := Value;
- Include(FUpdateMask, upHelpContext);
- UpdateControls;
- end;
-
- //[procedure TAction.SetHint]
- procedure TAction.SetHint(const Value: KOLString);
- begin
- if FHint = Value then exit;
- FHint := Value;
- Include(FUpdateMask, upHint);
- UpdateControls;
- end;
-
- //[procedure TAction.SetOnExecute]
- procedure TAction.SetOnExecute(const Value: TOnEvent);
- begin
- if @FOnExecute = @Value then exit;
- FOnExecute:=Value;
- UpdateControls;
- end;
-
- //[procedure TAction.SetVisible]
- procedure TAction.SetVisible(const Value: boolean);
- begin
- if FVisible = Value then exit;
- FVisible := Value;
- Include(FUpdateMask, upVisible);
- UpdateControls;
- end;
-
- //[procedure TAction.UpdateControls]
- procedure TAction.UpdateControls;
- var
- i: integer;
- begin
- if FUpdateMask = [] then exit;
- with FControls{-}^{+} do
- for i:=0 to Count - 1 do
- PControlRec(Items[i]).UpdateProc(Items[i]);
- FUpdateMask:=[];
- end;
-
- //[procedure TAction.UpdateCtrl]
- procedure TAction.UpdateCtrl(Sender: PControlRec);
- begin
- with Sender^, PControl(Ctrl){-}^{+} do begin
- if upCaption in FUpdateMask then
- Caption:=Self.FCaption;
- if upEnabled in FUpdateMask then
- Enabled:=Self.FEnabled;
- if upChecked in FUpdateMask then
- Checked:=Self.FChecked;
- if upVisible in FUpdateMask then
- Visible:=Self.FVisible;
- end;
- end;
-
- //[procedure TAction.UpdateMenu]
- procedure TAction.UpdateMenu(Sender: PControlRec);
- var
- s: KOLstring;
- begin
- with Sender^, PMenu(Ctrl).Items[ItemID]{-}^{+} do begin
- s:=Self.FCaption;
- {$ifndef wince}
- if Self.FShortCut <> '' then
- s:=s + #9 + Self.FShortCut;
- {$endif wince}
- if upCaption in FUpdateMask then
- Caption:=s;
- if upEnabled in FUpdateMask then
- Enabled:=Self.FEnabled;
- if upChecked in FUpdateMask then
- Checked:=Self.FChecked;
- if upVisible in FUpdateMask then
- Visible:=Self.FVisible;
- if upHelpContext in FUpdateMask then
- HelpContext:=Self.FHelpContext;
- if (upAccelerator in FUpdateMask) and (Self.FAccelerator.Key <> 0) then {YS} // Äîáàâèòü
- Accelerator:=Self.FAccelerator;
- end;
- end;
-
- //[procedure TAction.UpdateToolbar]
- procedure TAction.UpdateToolbar(Sender: PControlRec);
- var
- i: integer;
- s: KOLString;
- begin
- with Sender^, PControl(Ctrl){-}^{+} do begin
- i:=TBIndex2Item(ItemID);
- s:=TBButtonText[i];
- if (s <> '') and (upCaption in FUpdateMask) then
- TBButtonText[i]:=Self.FCaption;
- if upHint in FUpdateMask then
- TBSetTooltips(i, [PKOLChar(Self.FHint)]);
- if upEnabled in FUpdateMask then
- TBButtonEnabled[ItemID]:=Self.FEnabled;
- if upVisible in FUpdateMask then
- TBButtonVisible[ItemID]:=Self.FVisible;
- if upChecked in FUpdateMask then
- TBButtonChecked[ItemID]:=Self.FChecked;
- end;
- end;
-
- //[procedure TAction.SetAccelerator]
- procedure TAction.SetAccelerator(const Value: TMenuAccelerator);
- begin
- if (FAccelerator.fVirt = Value.fVirt) and (FAccelerator.Key = Value.Key) then exit;
- FAccelerator := Value;
- {$ifndef wince}
- Include(FUpdateMask, upAccelerator);
- FShortCut:=GetAcceleratorText(FAccelerator); // {YS}
- UpdateControls;
- {$endif wince}
- end;
-
- { TActionList }
-
- //[function TActionList.Add]
- function TActionList.Add(const ACaption, AHint: KOLstring; OnExecute: TOnEvent): PAction;
- begin
- Result:=NewAction(ACaption, AHint, OnExecute);
- FActions.Add(Result);
- end;
-
- //[procedure TActionList.Clear]
- procedure TActionList.Clear;
- begin
- while FActions.Count > 0 do
- Delete(0);
- FActions.Clear;
- end;
-
- //[procedure TActionList.Delete]
- procedure TActionList.Delete(Idx: integer);
- begin
- Actions[Idx].Free;
- FActions.Delete(Idx);
- end;
-
- //[destructor TActionList.Destroy]
- destructor TActionList.Destroy;
- begin
- {$ifdef USE_OnIdle}
- UnRegisterIdleHandler(DoUpdateActions);
- {$endif USE_OnIdle}
- Clear;
- FActions.Free;
- inherited;
- end;
-
- //[procedure TActionList.DoUpdateActions]
- procedure TActionList.DoUpdateActions(Sender: PObj);
- begin
- if Assigned(FOnUpdateActions) and (GetActiveWindow = FOwner.Handle) then
- FOnUpdateActions(PObj( @Self ));
- end;
-
- //[function TActionList.GetActions]
- function TActionList.GetActions(Idx: integer): PAction;
- begin
- Result:=FActions.Items[Idx];
- end;
-
- //[function TActionList.GetCount]
- function TActionList.GetCount: integer;
- begin
- Result:=FActions.Count;
- end;
-
- { -- TTree -- }
-
- {$IFDEF USE_CONSTRUCTORS}
- //[function NewTree]
- function NewTree( AParent: PTree; const AName: String ): PTree;
- begin
- New( Result, CreateTree( AParent, AName ) );
- end;
- //[END NewTree]
- {$ELSE not_USE_CONSTRUCTORS}
- //[function NewTree]
- {$IFDEF TREE_NONAME}
- function NewTree( AParent: PTree ): PTree;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PTree.Create;*){--}
- if AParent <> nil then
- AParent.Add( Result );
- Result.fParent := AParent;
- end;
- {$ELSE}
- {$IFDEF TREE_WIDE}
- function NewTree( AParent: PTree; const AName: WideString ): PTree;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PTree.Create;*){--}
- if AParent <> nil then
- AParent.Add( Result );
- Result.fParent := AParent;
- Result.fNodeName := AName;
- end;
- {$ELSE}
- function NewTree( AParent: PTree; const AName: String ): PTree;
- begin
- {-}
- New( Result, Create );
- {+}{++}(*Result := PTree.Create;*){--}
- if AParent <> nil then
- AParent.Add( Result );
- Result.fParent := AParent;
- Result.fNodeName := AName;
- end;
- {$ENDIF}
- {$ENDIF}
- //[END NewTree]
- {$ENDIF USE_CONSTRUCTORS}
-
- { TTree }
-
- //[procedure TTree.Add]
- procedure TTree.Add(Node: PTree);
- var Previous: PTree;
- begin
- Node.Unlink;
- if fChildren = nil then
- fChildren := NewList;
- Previous := nil;
- if PCrackList( fChildren ).fCount > 0 then
- Previous := PCrackList( fChildren ).fItems[ PCrackList( fChildren ).fCount - 1 ];
- if Previous <> nil then
- begin
- Previous.fNext := Node;
- Node.fPrev := Previous;
- end;
- fChildren.Add( Node );
- Node.fParent := @Self;
- end;
-
- //[procedure TTree.Clear]
- procedure TTree.Clear;
- var I: Integer;
- begin
- if fChildren = nil then Exit;
- for I := PCrackList( fChildren ).fCount - 1 downto 0 do
- PTree( PCrackList( fChildren ).fItems[ I ] ).Free;
- end;
-
- {$IFDEF USE_CONSTRUCTORS}
- //[constructor TTree.CreateTree]
- constructor TTree.CreateTree(AParent: PTree; const AName: String);
- begin
- inherited Create;
- if AParent <> nil then
- AParent.Add( @Self );
- fParent := AParent;
- fName := AName;
- end;
- {$ENDIF}
-
- //[destructor TTree.Destroy]
- destructor TTree.Destroy;
- begin
- Unlink;
- Clear;
- {$IFDEF TREE_NONAME}
- {$ELSE}
- fNodeName := '';
- {$ENDIF}
- inherited;
- end;
-
- //[function TTree.GetCount]
- function TTree.GetCount: Integer;
- begin
- Result := 0;
- if fChildren = nil then Exit;
- Result := PCrackList( fChildren ).fCount;
- end;
-
- //[function TTree.GetIndexAmongSiblings]
- function TTree.GetIndexAmongSiblings: Integer;
- begin
- Result := -1;
- if fParent = nil then Exit;
- Result := fParent.fChildren.IndexOf( @Self );
- end;
-
- //[function TTree.GetItems]
- function TTree.GetItems(Idx: Integer): PTree;
- begin
- Result := nil;
- if fChildren = nil then Exit;
- Result := fChildren.Items[ Idx ];
- end;
-
- //[function TTree.GetLevel]
- function TTree.GetLevel: Integer;
- var Node: PTree;
- begin
- Result := 0;
- Node := fParent;
- while Node <> nil do
- begin
- Inc( Result );
- Node := Node.fParent;
- end;
- end;
-
- //[function TTree.GetRoot]
- function TTree.GetRoot: PTree;
- begin
- Result := @Self;
- while Result.fParent <> nil do
- Result := Result.fParent;
- end;
-
- //[function TTree.GetTotal]
- function TTree.GetTotal: Integer;
- var I: Integer;
- begin
- Result := Count;
- if Result <> 0 then
- begin
- for I := 0 to Count - 1 do
- Result := Result + Items[ I ].Total;
- end;
- end;
-
- //[procedure TTree.Init]
- procedure TTree.Init;
- begin
- if FParent <> nil then
- FParent.Add( @Self );
- end;
-
- //[procedure TTree.Insert]
- procedure TTree.Insert(Before, Node: PTree);
- var Previous: PTree;
- begin
- Node.Unlink;
- if fChildren = nil then
- fChildren := NewList;
- Previous := nil;
- if Before <> nil then
- Previous := Before.fPrev;
- if Previous <> nil then
- begin
- Previous.fNext := Node;
- Node.fPrev := Previous;
- end;
- if Before <> nil then
- begin
- Node.fNext := Before;
- Before.fPrev := Node;
- fChildren.Insert( fChildren.IndexOf( Before ), Node );
- end
- else
- fChildren.Add( Node );
- Node.fParent := @Self;
- end;
-
- //[function CompareTreeNodes]
- function CompareTreeNodes( const Data: Pointer; const e1, e2: DWORD ): Integer;
- var List: PList;
- begin
- List := Data;
- {$IFDEF TREE_NONAME}
- Result := DWORD( PTree( PCrackList( List ).fItems[ e1 ] ).fData ) -
- DWORD( PTree( PCrackList( List ).fItems[ e2 ] ).fData );
- {$ELSE}
- Result := AnsiCompareStr( PTree( PCrackList( List ).fItems[ e1 ] ).fNodeName,
- PTree( PCrackList( List ).fItems[ e2 ] ).fNodeName );
- {$ENDIF}
- end;
-
- //[procedure SwapTreeNodes]
- procedure SwapTreeNodes( const Data: Pointer; const e1, e2: DWORD );
- var List: PList;
- begin
- List := Data;
- List.Swap( e1, e2 );
- end;
-
- //[procedure TTree.SwapNodes]
- procedure TTree.SwapNodes( i1, i2: Integer );
- begin
- fChildren.Swap( i1, i2 );
- end;
-
- //[procedure TTree.SortByName]
- procedure TTree.SortByName;
- begin
- if Count <= 1 then Exit;
- SortData( fChildren, PCrackList( fChildren ).fCount, CompareTreeNodes, SwapTreeNodes );
- end;
-
- //[procedure TTree.Unlink]
- procedure TTree.Unlink;
- var I: Integer;
- begin
- if fPrev <> nil then
- fPrev.fNext := fNext;
- if fNext <> nil then
- fNext.fPrev := fPrev;
- if (fParent <> nil) then
- begin
- I := fParent.fChildren.IndexOf( @Self );
- fParent.fChildren.Delete( I );
- if PCrackList( fParent.fChildren ).fCount = 0 then
- begin
- fParent.fChildren.Free;
- fParent.fChildren := nil;
- end;
- end;
- fPrev := nil;
- fNext := nil;
- fParent := nil;
- end;
-
- //[function TTree.IsParentOfNode]
- function TTree.IsParentOfNode(Node: PTree): Boolean;
- begin
- Result := TRUE;
- while Node <> nil do
- begin
- if Node = @ Self then Exit;
- Node := Node.Parent;
- end;
- Result := FALSE;
- end;
-
- //[function TTree.IndexOf]
- function TTree.IndexOf(Node: PTree): Integer;
- begin
- Result := -1;
- if not IsParentOfNode( Node ) then Exit;
- while Node <> @ Self do
- begin
- Inc( Result );
- while Node.PrevSibling <> nil do
- begin
- Node := Node.PrevSibling;
- Inc( Result, 1 + Node.Total );
- end;
- Node := Node.Parent;
- end;
- end;
-
- {-------------------------------------------------------------------------------
- ADDITIONAL UTILITIES
- }
-
- function MapFileRead( const Filename: String; var hFile, hMap: THandle ): Pointer;
- var Sz, Hi: DWORD;
- begin
- Result := nil;
- hFile := FileCreate( Filename, ofOpenRead or ofOpenExisting or ofShareDenyNone );
- hMap := 0;
- if hFile = INVALID_HANDLE_VALUE then Exit;
- Sz := GetFileSize( hFile, @ Hi );
- hMap := CreateFileMapping( hFile, nil, PAGE_READONLY, Hi, Sz, nil );
- if hMap = 0 then Exit;
- if (Hi <> 0) or (Sz > $0FFFFFFF) then Sz := $0FFFFFFF;
- Result := MapViewOfFile( hMap, FILE_MAP_READ, 0, 0, Sz );
- end;
-
- function MapFile( const Filename: String; var hFile, hMap: THandle ): Pointer;
- var Sz, Hi: DWORD;
- begin
- Result := nil;
- hFile := FileCreate( Filename, ofOpenRead or ofOpenWrite or ofOpenExisting
- or ofShareExclusive );
- hMap := 0;
- if hFile = INVALID_HANDLE_VALUE then Exit;
- Sz := GetFileSize( hFile, @ Hi );
- hMap := CreateFileMapping( hFile, nil, PAGE_READWRITE, Hi, Sz, nil );
- if hMap = 0 then Exit;
- if (Hi <> 0) or (Sz > $0FFFFFFF) then Sz := $0FFFFFFF;
- Result := MapViewOfFile( hMap, FILE_MAP_READ, 0, 0, Sz );
- end;
-
- procedure UnmapFile( BasePtr: Pointer; hFile, hMap: THandle );
- begin
- if BasePtr <> nil then
- UnmapViewOfFile( BasePtr );
- if hMap <> 0 then
- CloseHandle( hMap );
- if hFile <> INVALID_HANDLE_VALUE then
- CloseHandle( hFile );
- end;
-
- //[procedure CloseMsg]
- procedure CloseMsg( Dummy, Dialog: PControl; var Accept: Boolean );
- begin
- Accept := FALSE;
- Dialog.ModalResult := -1;
- end;
- //[END CloseMsg]
-
- //[procedure OKClick]
- procedure OKClick( Dialog, Btn: PControl );
- var Rslt: Integer;
- begin
- Rslt := -1;
- if Btn <> nil then
- Rslt := Btn.Tag;
- Dialog.ModalResult := Rslt;
- Dialog.Close;
- end;
- //[END OKClick]
-
- //[procedure KeyClick]
- procedure KeyClick( Dialog, Btn: PControl; var Key: Longint; Shift: DWORD );
- begin
- if (Key = VK_RETURN) or (Key = VK_ESCAPE) then
- begin
- if Key = VK_ESCAPE then
- Btn := nil;
- OKClick( Dialog, Btn );
- end;
- end;
- //[END KeyClick]
-
- //[function ShowQuestionEx]
- function ShowQuestionEx( S: KOLString; Answers: KOLString; CallBack: TOnEvent ): Integer;
- {$IFDEF F_P105ORBELOW}
- type POnEvent = ^TOnEvent;
- PONKey = ^TOnKey;
- var M: TMethod;
- {$ENDIF F_P105ORBELOW}
- var Dialog: PControl;
- DlgPrnt: PControl;
- Buttons: PList;
- Btn: PControl;
- AppTermFlag: Boolean;
- Lab: PControl;
- {$IFNDEF USE_GRUSH} Y, {$ELSE} {$IFDEF TOGRUSH_OPTIONAL} Y, {$ENDIF} {$ENDIF} W, X, I: Integer;
- Title: String;
- DlgWnd: HWnd;
- AppCtl: PControl;
- {$IFDEF USE_GRUSH}
- Sz: TSize;
- H: Integer;
- Bmp: PBitmap;
- {$ENDIF}
- {$IFNDEF NO_CHECK_STAYONTOP}
- CurForm: PControl;
- DoStayOnTop: Boolean;
- {$ENDIF}
- begin
- AppTermFlag := AppletTerminated;
- AppCtl := Applet;
- AppletTerminated := FALSE;
- Title := 'Information';
- if pos( '/', Answers ) > 0 then
- Title := 'Question';
- {$IFNDEF NO_CHECK_STAYONTOP}
- DoStayOnTop := FALSE;
- {$ENDIF NO_CHECK_STAYONTOP}
- if Applet <> nil then
- begin
- Title := Applet.Caption;
- {$IFNDEF NO_CHECK_STAYONTOP}
- CurForm := Applet.ActiveControl;
- DoStayOnTop := CurForm.StayOnTop;
- {$ENDIF NO_CHECK_STAYONTOP}
- end;
- {$IFNDEF NOT_ALLOW_EXTRACT_TITLE}
- if (Length( S ) > 2) and (S[ 1 ] = '!') then
- begin
- Delete( S, 1, 1 );
- if S[ 1 ] = '!' then Delete( S, 1, 1 )
- else Title := Parse( S, '!' );
- end;
- {$ENDIF}
- Dialog := NewForm( Applet, Title ).SetSize( 300, 40 );
- {$IFNDEF NO_CHECK_STAYONTOP}
- if DoStayOnTop then
- Dialog.StayOnTop := TRUE;
- {$ENDIF NO_CHECK_STAYONTOP}
- Dialog.Style := Dialog.Style and not (WS_MINIMIZEBOX or WS_MAXIMIZEBOX);
- Dialog.OnClose := TOnEventAccept( MakeMethod( Dialog, @CloseMsg ) );
-
- {$IFDEF USE_GRUSH}
- Bmp := NewBitmap( 1, 1 );
- {$IFDEF TOGRUSH_OPTIONAL}
- if not NoGrush then
- {$ENDIF TOGRUSH_OPTIONAL}
- begin
- Dialog.Color := clGRushLight;
- Dialog.Font.FontName := 'Arial';
- Dialog.Font.FontHeight := 16;
- DlgPrnt := NewPanel( Dialog, esNone ); //.SetAlign( caClient );
- end
- {$IFDEF TOGRUSH_OPTIONAL}
- else
- DlgPrnt := Dialog;
- {$ENDIF TOGRUSH_OPTIONAL}
- ;
- {$ELSE}
- DlgPrnt := Dialog;
- {$ENDIF USE_GRUSH}
-
- DlgPrnt.Margin := 8;
-
- {$IFDEF USE_GRUSH}
- {$IFDEF TOGRUSH_OPTIONAL}
- if not NoGrush then
- {$ENDIF TOGRUSH_OPTIONAL}
- begin
- Lab := NewWordWrapLabel( DlgPrnt, S ).SetSize( 278, 20 );
- Lab.AutoSize( TRUE );
- Lab.Transparent := TRUE;
- end
- {$IFDEF TOGRUSH_OPTIONAL}
- else
- begin
- Lab := NewEditbox( DlgPrnt, [ eoMultiline, eoReadonly, eoNoHScroll, eoNoVScroll ] ).SetSize( 278, 20 );
- Lab.HasBorder := FALSE;
- Lab.Color := clBtnFace;
- Lab.Caption := S;
- Lab.Style := Lab.Style and not WS_TABSTOP;
- Lab.TabStop := FALSE;
- while TRUE do
- begin
- Y := HiWord( Lab.Perform( EM_POSFROMCHAR, Length( S ) - 1, 0 ) );
- if Y < Lab.Height - 20 then break;
- Lab.Height := Lab.Height + 4;
- if Lab.Height + 40 > GetSystemMetrics( SM_CYSCREEN ) then break;
- end;
- end
- {$ENDIF TOGRUSH_OPTIONAL}
- ;
- {$ELSE}
- Lab := NewEditbox( DlgPrnt, [ eoMultiline, eoReadonly, eoNoHScroll, eoNoVScroll ] ).SetSize( 278, 20 );
- Lab.HasBorder := FALSE;
- Lab.Color := clBtnFace;
- Lab.Caption := S;
- Lab.Style := Lab.Style and not WS_TABSTOP;
- Lab.TabStop := FALSE;
-
- //Lab.CreateWindow; //virtual!!! -- not needed, window created in Perform
- while TRUE do
- begin
- Y := HiWord( Lab.Perform( EM_POSFROMCHAR, Length( S ) - 1, 0 ) );
- if Y < Lab.Height - 20 then break;
- Lab.Height := Lab.Height + 4;
- if Lab.Height + 40 > GetSystemMetrics( SM_CYSCREEN ) then break;
- end;
- //Lab.LikeSpeedButton;
-
- {$ENDIF USE_GRUSH}
-
- Buttons := NewList;
- W := 0;
-
- {$IFDEF USE_GRUSH}
- H := 0;
- {$ENDIF}
-
- if Answers = '' then
- begin
- Btn := NewButton( DlgPrnt, ' OK ' ).PlaceUnder;
-
- {$IFDEF USE_GRUSH}
- {$IFDEF TOGRUSH_OPTIONAL}
- if not NoGrush then
- {$ENDIF TOGRUSH_OPTIONAL}
- begin
- Sz := Bmp.Canvas.TextExtent( Btn.Caption );
- if H = 0 then H := Sz.cy + 8;
- Btn.SetSize( Sz.cx + 16, H );
- end;
- {$ENDIF}
-
- W := Btn.BoundsRect.Right;
- Buttons.Add( Btn );
- end
- else
- while Answers <> '' do
- begin
- Btn := NewButton( DlgPrnt, ' ' + Parse( Answers, '/' ) + ' ' );
- Buttons.Add( Btn );
- if W = 0 then
- Btn.PlaceUnder
- else
- Btn.PlaceRight;
-
- {$IFDEF USE_GRUSH}
- {$IFDEF TOGRUSH_OPTIONAL}
- if not NoGrush then
- {$ENDIF TOGRUSH_OPTIONAL}
- begin
- Sz := Bmp.Canvas.TextExtent( Btn.Caption );
- if H = 0 then H := Sz.cy + 8;
- Btn.SetSize( Sz.cx + 16, H );
- end
- {$IFDEF TOGRUSH_OPTIONAL}
- else Btn.AutoSize( TRUE )
- {$ENDIF TOGRUSH_OPTIONAL}
- ;
- {$ELSE}
- Btn.AutoSize( TRUE );
- {$ENDIF USE_GRUSH}
-
- if W > 0 then
- begin
- //Inc( W, 6 );
- Btn.Left := Btn.Left + 6;
- end;
- W := Btn.BoundsRect.Right;
- end;
- DlgPrnt.Width := Max( Max( DlgPrnt.Width, Lab.Left + Lab.Width + 4 ), W + 8 );
- X := (DlgPrnt.ClientWidth - W) div 2;
- for I := 0 to Buttons.Count-1 do
- begin
- Btn := Buttons.Items[ I ];
- Btn.Tag := I + 1;
- {$IFDEF F_P105ORBELOW}
- M := MakeMethod( Dialog, @OKClick );
- Btn.OnClick := POnEvent( @ M )^;
- M := MakeMethod( Dialog, @KeyClick );
- Btn.OnKeyDown := POnKey( @ M )^;
- {$ELSE}
- Btn.OnClick := TOnEvent( MakeMethod( Dialog, @OKClick ) );
- Btn.OnKeyDown := TOnKey( MakeMethod( Dialog, @KeyClick ) );
- {$ENDIF}
- Btn.Left := Btn.Left + X;
- if I = 0 then
- begin
- Btn.ResizeParentBottom;
- Dialog.ActiveControl := Btn;
- end;
- end;
-
- {$IFDEF USE_GRUSH}
- {$IFDEF TOGRUSH_OPTIONAL}
- if not NoGrush then
- {$ENDIF TOGRUSH_OPTIONAL}
- begin
- DlgPrnt.ResizeParent;
- end;
- Bmp.Free;
- {$ENDIF USE_GRUSH}
-
- Dialog.CenterOnParent.Tabulate.CanResize := FALSE;
- Buttons.Free;
-
- if Assigned( CallBack ) then
- CallBack( Dialog );
- Dialog.CreateWindow; // virtual!!!
-
- if (Applet <> nil) and Applet.IsApplet then
- begin
- Dialog.ShowModal;
- Result := Dialog.ModalResult;
- Dialog.Free;
- end
- else
- begin
- DlgWnd := Dialog.Handle;
- while IsWindow( DlgWnd ) and (Dialog.ModalResult = 0) do
- Dialog.ProcessMessage;
- Result := Dialog.ModalResult;
- Dialog.Free;
- CreatingWindow := nil;
- Applet := AppCtl;
- end;
-
- AppletTerminated := AppTermFlag;
- end;
- //[END ShowQuestionEx]
-
- //[function ShowQuestion]
- function ShowQuestion( const S: String; Answers: String ): Integer;
- begin
- Result := ShowQuestionEx( S, Answers, nil );
- end;
- //[END ShowQuestion]
-
- //[procedure ShowMsgModal]
- procedure ShowMsgModal( const S: String );
- begin
- ShowQuestion( S, '' );
- end;
- //[END ShowMsgModal]
-
- end.
|